diff --git a/lapack-netlib/SRC/dppsvx.c b/lapack-netlib/SRC/dppsvx.c new file mode 100644 index 000000000..fb4f43c21 --- /dev/null +++ b/lapack-netlib/SRC/dppsvx.c @@ -0,0 +1,925 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DPPSVX 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 DPPSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, */ +/* X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), */ +/* $ FERR( * ), S( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */ +/* > compute the solution to a real system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric positive definite 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 = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* > factor the matrix A (after equilibration if FACT = 'E') as */ +/* > A = U**T* U, if UPLO = 'U', or */ +/* > A = L * L**T, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is a lower triangular */ +/* > matrix. */ +/* > */ +/* > 3. If the leading i-by-i principal minor is not positive definite, */ +/* > then the routine returns with INFO = i. Otherwise, the factored */ +/* > form of A is used to estimate the condition number of the matrix */ +/* > A. If the reciprocal of the condition number is less than machine */ +/* > precision, INFO = N+1 is returned as a warning, but the routine */ +/* > still goes on to solve for X and compute error bounds as */ +/* > described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(S) so that it solves the original system before */ +/* > equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AFP contains the factored form of A. */ +/* > If EQUED = 'Y', the matrix A has been equilibrated */ +/* > with scaling factors given by S. AP and AFP will not */ +/* > be modified. */ +/* > = 'N': The matrix A will be copied to AFP and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > 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,out] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array, except if FACT = 'F' */ +/* > and EQUED = 'Y', then A must contain the equilibrated matrix */ +/* > diag(S)*A*diag(S). 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. A is not modified if */ +/* > FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ +/* > */ +/* > On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* > diag(S)*A*diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFP */ +/* > \verbatim */ +/* > AFP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > If FACT = 'F', then AFP is an input argument and on entry */ +/* > contains the triangular factor U or L from the Cholesky */ +/* > factorization A = U**T*U or A = L*L**T, in the same storage */ +/* > format as A. If EQUED .ne. 'N', then AFP is the factored */ +/* > form of the equilibrated matrix A. */ +/* > */ +/* > If FACT = 'N', then AFP is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**T * U or A = L * L**T of the original */ +/* > matrix A. */ +/* > */ +/* > If FACT = 'E', then AFP is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**T * U or A = L * L**T of the equilibrated */ +/* > matrix A (see the description of AP for the form of the */ +/* > equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A; not accessed if EQUED = 'N'. S is */ +/* > an input argument if FACT = 'F'; otherwise, S is an output */ +/* > argument. If FACT = 'F' and EQUED = 'Y', each element of S */ +/* > must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ +/* > B is overwritten by diag(S) * 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 DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ +/* > the original system of equations. Note that if EQUED = 'Y', */ +/* > A and B are modified on exit, and the solution to the */ +/* > equilibrated system is inv(diag(S))*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 after equilibration (if done). If RCOND is less than the */ +/* > machine precision (in particular, if RCOND = 0), the matrix */ +/* > is singular to working precision. This condition is */ +/* > indicated by a return code of INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the leading minor of order i of A is */ +/* > not positive definite, so the factorization */ +/* > could not be completed, and the solution has not */ +/* > been computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the symmetric 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 dppsvx_(char *fact, char *uplo, integer *n, integer * + nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s, + doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * + rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + doublereal amax, smin, smax; + integer i__, j; + extern logical lsame_(char *, char *); + doublereal scond, anorm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical equil, rcequ; + extern doublereal dlamch_(char *); + logical nofact; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal dlansp_(char *, char *, integer *, doublereal *, + doublereal *); + extern /* Subroutine */ int dppcon_(char *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *), dlaqsp_(char *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, char *); + integer infequ; + extern /* Subroutine */ int dppequ_(char *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *), + dpprfs_(char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, integer *), + dpptrf_(char *, integer *, doublereal *, integer *); + doublereal smlnum; + extern /* Subroutine */ int dpptrs_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *); + + +/* -- 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..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --ap; + --afp; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = FALSE_; + } else { + rcequ = lsame_(equed, "Y"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! 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 (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -7; + } else { + if (rcequ) { + smin = bignum; + smax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = smin, d__2 = s[j]; + smin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[j]; + smax = f2cmax(d__1,d__2); +/* L10: */ + } + if (smin <= 0.) { + *info = -8; + } else if (*n > 0) { + scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + } else { + scond = 1.; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldx < f2cmax(1,*n)) { + *info = -12; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPSVX", &i__1, (ftnlen)6); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1]; +/* L20: */ + } +/* L30: */ + } + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization A = U**T * U or A = L * L**T. */ + + i__1 = *n * (*n + 1) / 2; + dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); + dpptrf_(uplo, n, &afp[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlansp_("I", uplo, n, &ap[1], &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info); + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset], + ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1]; +/* L40: */ + } +/* L50: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= scond; +/* L60: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DPPSVX */ + +} /* dppsvx_ */ + diff --git a/lapack-netlib/SRC/dpptrf.c b/lapack-netlib/SRC/dpptrf.c new file mode 100644 index 000000000..b1e3b151a --- /dev/null +++ b/lapack-netlib/SRC/dpptrf.c @@ -0,0 +1,643 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPPTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPPTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPPTRF computes the Cholesky factorization of a real symmetric */ +/* > positive definite matrix A stored in packed format. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**T * U, if UPLO = 'U', or */ +/* > A = L * L**T, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular. */ +/* > \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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > */ +/* > On exit, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**T*U or A = L*L**T, in the same */ +/* > storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the symmetric matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = aji) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dpptrf_(char *uplo, integer *n, doublereal *ap, integer * + info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *); + integer j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *); + integer jc, jj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the Cholesky factorization A = U**T*U. */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + +/* Compute elements 1:J-1 of column J. */ + + if (j > 1) { + i__2 = j - 1; + dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[ + jc], &c__1); + } + +/* Compute U(J,J) and test for non-positive-definiteness. */ + + i__2 = j - 1; + ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1); + if (ajj <= 0.) { + ap[jj] = ajj; + goto L30; + } + ap[jj] = sqrt(ajj); +/* L10: */ + } + } else { + +/* Compute the Cholesky factorization A = L*L**T. */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute L(J,J) and test for non-positive-definiteness. */ + + ajj = ap[jj]; + if (ajj <= 0.) { + ap[jj] = ajj; + goto L30; + } + ajj = sqrt(ajj); + ap[jj] = ajj; + +/* Compute elements J+1:N of column J and update the trailing */ +/* submatrix. */ + + if (j < *n) { + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &ap[jj + 1], &c__1); + i__2 = *n - j; + dspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n + - j + 1]); + jj = jj + *n - j + 1; + } +/* L20: */ + } + } + goto L40; + +L30: + *info = j; + +L40: + return 0; + +/* End of DPPTRF */ + +} /* dpptrf_ */ + diff --git a/lapack-netlib/SRC/dpptri.c b/lapack-netlib/SRC/dpptri.c new file mode 100644 index 000000000..6704f98ea --- /dev/null +++ b/lapack-netlib/SRC/dpptri.c @@ -0,0 +1,595 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPPTRI computes the inverse of a real symmetric positive definite */ +/* > matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ +/* > computed by DPPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular factor is stored in AP; */ +/* > = 'L': Lower triangular factor is stored in AP. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the triangular factor U or L from the Cholesky */ +/* > factorization A = U**T*U or A = L*L**T, packed columnwise as */ +/* > a linear array. The j-th column of U or L is stored in the */ +/* > array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the upper or lower triangle of the (symmetric) */ +/* > inverse of A, overwriting the input factor U or L. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the (i,i) element of the factor U or L is */ +/* > zero, and the 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 doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer * + info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *); + integer j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *); + logical upper; + integer jc, jj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dtptri_( + char *, char *, integer *, doublereal *, integer *); + doublereal ajj; + integer jjn; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Invert the triangular Cholesky factor U or L. */ + + dtptri_(uplo, "Non-unit", n, &ap[1], info); + if (*info > 0) { + return 0; + } + + if (upper) { + +/* Compute the product inv(U) * inv(U)**T. */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + if (j > 1) { + i__2 = j - 1; + dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]); + } + ajj = ap[jj]; + dscal_(&j, &ajj, &ap[jc], &c__1); +/* L10: */ + } + + } else { + +/* Compute the product inv(L)**T * inv(L). */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jjn = jj + *n - j + 1; + i__2 = *n - j + 1; + ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1); + if (j < *n) { + i__2 = *n - j; + dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ + jj + 1], &c__1); + } + jj = jjn; +/* L20: */ + } + } + + return 0; + +/* End of DPPTRI */ + +} /* dpptri_ */ + diff --git a/lapack-netlib/SRC/dpptrs.c b/lapack-netlib/SRC/dpptrs.c new file mode 100644 index 000000000..9ab6cc14e --- /dev/null +++ b/lapack-netlib/SRC/dpptrs.c @@ -0,0 +1,599 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* DOUBLE PRECISION AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPPTRS solves a system of linear equations A*X = B with a symmetric */ +/* > positive definite matrix A in packed storage using the Cholesky */ +/* > factorization A = U**T*U or A = L*L**T computed by DPPTRF. */ +/* > \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 matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**T*U or A = L*L**T, packed columnwise in a linear */ +/* > array. The j-th column of U or L is stored in the array AP */ +/* > as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, 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 doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dpptrs_(char *uplo, integer *n, integer *nrhs, + doublereal *ap, doublereal *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + 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 = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPTRS", &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**T * U. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U**T *X = B, overwriting B with X. */ + + dtpsv_("Upper", "Transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); + +/* Solve U*X = B, overwriting B with X. */ + + dtpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Solve A*X = B where A = L * L**T. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve L*Y = B, overwriting B with X. */ + + dtpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); + +/* Solve L**T *X = Y, overwriting B with X. */ + + dtpsv_("Lower", "Transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); +/* L20: */ + } + } + + return 0; + +/* End of DPPTRS */ + +} /* dpptrs_ */ + diff --git a/lapack-netlib/SRC/dpstf2.c b/lapack-netlib/SRC/dpstf2.c new file mode 100644 index 000000000..919cb47ed --- /dev/null +++ b/lapack-netlib/SRC/dpstf2.c @@ -0,0 +1,831 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive +semidefinite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPSTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) */ + +/* DOUBLE PRECISION TOL */ +/* INTEGER INFO, LDA, N, RANK */ +/* CHARACTER UPLO */ +/* DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) */ +/* INTEGER PIV( N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPSTF2 computes the Cholesky factorization with complete */ +/* > pivoting of a real symmetric positive semidefinite matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > P**T * A * P = U**T * U , if UPLO = 'U', */ +/* > P**T * A * P = L * L**T, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular, and */ +/* > P is stored as vector PIV. */ +/* > */ +/* > This algorithm does not attempt to check that A is positive */ +/* > semidefinite. This version of the algorithm calls level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n by n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization as above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PIV */ +/* > \verbatim */ +/* > PIV is INTEGER array, dimension (N) */ +/* > PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of A given by the number of steps the algorithm */ +/* > completed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOL */ +/* > \verbatim */ +/* > TOL is DOUBLE PRECISION */ +/* > User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */ +/* > will be used. The algorithm terminates at the (K-1)st step */ +/* > if the pivot <= TOL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > Work space. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > < 0: If INFO = -K, the K-th argument had an illegal value, */ +/* > = 0: algorithm completed successfully, and */ +/* > > 0: the matrix A is either rank deficient with computed rank */ +/* > as returned in RANK, or is not positive semidefinite. See */ +/* > Section 7 of LAPACK Working Note #161 for further */ +/* > information. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dpstf2_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + + integer i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + doublereal dtemp; + integer itemp; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal dstop; + logical upper; + extern doublereal dlamch_(char *); + extern logical disnan_(doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ajj; + integer pvt; + + +/* -- 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; + --piv; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPSTF2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Initialize PIV */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + piv[i__] = i__; +/* L100: */ + } + +/* Compute stopping value */ + + pvt = 1; + ajj = a[pvt + pvt * a_dim1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (a[i__ + i__ * a_dim1] > ajj) { + pvt = i__; + ajj = a[pvt + pvt * a_dim1]; + } + } + if (ajj <= 0. || disnan_(&ajj)) { + *rank = 0; + *info = 1; + goto L170; + } + +/* Compute stopping value if not supplied */ + + if (*tol < 0.) { + dstop = *n * dlamch_("Epsilon") * ajj; + } else { + dstop = *tol; + } + +/* Set first half of WORK to zero, holds dot products */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L110: */ + } + + if (upper) { + +/* Compute the Cholesky factorization P**T * A * P = U**T * U */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + + if (j > 1) { +/* Computing 2nd power */ + d__1 = a[j - 1 + i__ * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L120: */ + } + + if (j > 1) { + i__2 = *n + j; + i__3 = *n << 1; + itemp = mymaxloc_(&work[1], &i__2, &i__3, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L160; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__2 = j - 1; + dswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1], + &c__1); + if (pvt < *n) { + i__2 = *n - pvt; + dswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + ( + pvt + 1) * a_dim1], lda); + } + i__2 = pvt - j - 1; + dswap_(&i__2, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + pvt * + a_dim1], &c__1); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of row J */ + + if (j < *n) { + i__2 = j - 1; + i__3 = *n - j; + dgemv_("Trans", &i__2, &i__3, &c_b17, &a[(j + 1) * a_dim1 + 1] + , lda, &a[j * a_dim1 + 1], &c__1, &c_b19, &a[j + (j + + 1) * a_dim1], lda); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); + } + +/* L130: */ + } + + } else { + +/* Compute the Cholesky factorization P**T * A * P = L * L**T */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + + if (j > 1) { +/* Computing 2nd power */ + d__1 = a[i__ + (j - 1) * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L140: */ + } + + if (j > 1) { + i__2 = *n + j; + i__3 = *n << 1; + itemp = mymaxloc_(&work[1], &i__2, &i__3, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L160; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__2 = j - 1; + dswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda); + if (pvt < *n) { + i__2 = *n - pvt; + dswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1 + + pvt * a_dim1], &c__1); + } + i__2 = pvt - j - 1; + dswap_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + (j + 1) + * a_dim1], lda); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of column J */ + + if (j < *n) { + i__2 = *n - j; + i__3 = j - 1; + dgemv_("No Trans", &i__2, &i__3, &c_b17, &a[j + 1 + a_dim1], + lda, &a[j + a_dim1], lda, &c_b19, &a[j + 1 + j * + a_dim1], &c__1); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } + +/* L150: */ + } + + } + +/* Ran to completion, A has full rank */ + + *rank = *n; + + goto L170; +L160: + +/* Rank is number of steps completed. Set INFO = 1 to signal */ +/* that the factorization cannot be used to solve a system. */ + + *rank = j - 1; + *info = 1; + +L170: + return 0; + +/* End of DPSTF2 */ + +} /* dpstf2_ */ + diff --git a/lapack-netlib/SRC/dpstrf.c b/lapack-netlib/SRC/dpstrf.c new file mode 100644 index 000000000..6feaed59e --- /dev/null +++ b/lapack-netlib/SRC/dpstrf.c @@ -0,0 +1,910 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPSTRF computes the Cholesky factorization with complete pivoting of a real symmetric positive +semidefinite matrix. */ + + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPSTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) */ + +/* DOUBLE PRECISION TOL */ +/* INTEGER INFO, LDA, N, RANK */ +/* CHARACTER UPLO */ +/* DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) */ +/* INTEGER PIV( N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPSTRF computes the Cholesky factorization with complete */ +/* > pivoting of a real symmetric positive semidefinite matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > P**T * A * P = U**T * U , if UPLO = 'U', */ +/* > P**T * A * P = L * L**T, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular, and */ +/* > P is stored as vector PIV. */ +/* > */ +/* > This algorithm does not attempt to check that A is positive */ +/* > semidefinite. This version of the algorithm calls level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n by n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization as above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PIV */ +/* > \verbatim */ +/* > PIV is INTEGER array, dimension (N) */ +/* > PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of A given by the number of steps the algorithm */ +/* > completed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOL */ +/* > \verbatim */ +/* > TOL is DOUBLE PRECISION */ +/* > User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */ +/* > will be used. The algorithm terminates at the (K-1)st step */ +/* > if the pivot <= TOL. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > Work space. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > < 0: If INFO = -K, the K-th argument had an illegal value, */ +/* > = 0: algorithm completed successfully, and */ +/* > > 0: the matrix A is either rank deficient with computed rank */ +/* > as returned in RANK, or is not positive semidefinite. See */ +/* > Section 7 of LAPACK Working Note #161 for further */ +/* > information. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dpstrf_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + + /* Local variables */ + + integer i__, j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + doublereal dtemp; + integer itemp; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal dstop; + logical upper; + extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *), dpstf2_(char *, integer *, + doublereal *, integer *, integer *, integer *, doublereal *, + doublereal *, integer *); + integer jb, nb; + extern doublereal dlamch_(char *); + extern logical disnan_(doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + doublereal ajj; + integer pvt; + + +/* -- 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; + --piv; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPSTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get block size */ + + nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dpstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1], + info); + goto L200; + + } else { + +/* Initialize PIV */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + piv[i__] = i__; +/* L100: */ + } + +/* Compute stopping value */ + + pvt = 1; + ajj = a[pvt + pvt * a_dim1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (a[i__ + i__ * a_dim1] > ajj) { + pvt = i__; + ajj = a[pvt + pvt * a_dim1]; + } + } + if (ajj <= 0. || disnan_(&ajj)) { + *rank = 0; + *info = 1; + goto L200; + } + +/* Compute stopping value if not supplied */ + + if (*tol < 0.) { + dstop = *n * dlamch_("Epsilon") * ajj; + } else { + dstop = *tol; + } + + + if (upper) { + +/* Compute the Cholesky factorization P**T * A * P = U**T * U */ + + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + +/* Account for last block not being NB wide */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - k + 1; + jb = f2cmin(i__3,i__4); + +/* Set relevant part of first half of WORK to zero, */ +/* holds dot products */ + + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] = 0.; +/* L110: */ + } + + i__3 = k + jb - 1; + for (j = k; j <= i__3; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__4 = *n; + for (i__ = j; i__ <= i__4; ++i__) { + + if (j > k) { +/* Computing 2nd power */ + d__1 = a[j - 1 + i__ * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L120: */ + } + + if (j > 1) { + i__4 = *n + j; + i__5 = *n << 1; + itemp = mymaxloc_(&work[1], &i__4, &i__5, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L190; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__4 = j - 1; + dswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt * + a_dim1 + 1], &c__1); + if (pvt < *n) { + i__4 = *n - pvt; + dswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[ + pvt + (pvt + 1) * a_dim1], lda); + } + i__4 = pvt - j - 1; + dswap_(&i__4, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + + pvt * a_dim1], &c__1); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of row J. */ + + if (j < *n) { + i__4 = j - k; + i__5 = *n - j; + dgemv_("Trans", &i__4, &i__5, &c_b23, &a[k + (j + 1) * + a_dim1], lda, &a[k + j * a_dim1], &c__1, & + c_b25, &a[j + (j + 1) * a_dim1], lda); + i__4 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__4, &d__1, &a[j + (j + 1) * a_dim1], lda); + } + +/* L130: */ + } + +/* Update trailing matrix, J already incremented */ + + if (k + jb <= *n) { + i__3 = *n - j + 1; + dsyrk_("Upper", "Trans", &i__3, &jb, &c_b23, &a[k + j * + a_dim1], lda, &c_b25, &a[j + j * a_dim1], lda); + } + +/* L140: */ + } + + } else { + +/* Compute the Cholesky factorization P**T * A * P = L * L**T */ + + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + +/* Account for last block not being NB wide */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - k + 1; + jb = f2cmin(i__3,i__4); + +/* Set relevant part of first half of WORK to zero, */ +/* holds dot products */ + + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] = 0.; +/* L150: */ + } + + i__3 = k + jb - 1; + for (j = k; j <= i__3; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__4 = *n; + for (i__ = j; i__ <= i__4; ++i__) { + + if (j > k) { +/* Computing 2nd power */ + d__1 = a[i__ + (j - 1) * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L160: */ + } + + if (j > 1) { + i__4 = *n + j; + i__5 = *n << 1; + itemp = mymaxloc_(&work[1], &i__4, &i__5, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L190; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__4 = j - 1; + dswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1], + lda); + if (pvt < *n) { + i__4 = *n - pvt; + dswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[ + pvt + 1 + pvt * a_dim1], &c__1); + } + i__4 = pvt - j - 1; + dswap_(&i__4, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + + (j + 1) * a_dim1], lda); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of column J. */ + + if (j < *n) { + i__4 = *n - j; + i__5 = j - k; + dgemv_("No Trans", &i__4, &i__5, &c_b23, &a[j + 1 + k + * a_dim1], lda, &a[j + k * a_dim1], lda, & + c_b25, &a[j + 1 + j * a_dim1], &c__1); + i__4 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__4, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } + +/* L170: */ + } + +/* Update trailing matrix, J already incremented */ + + if (k + jb <= *n) { + i__3 = *n - j + 1; + dsyrk_("Lower", "No Trans", &i__3, &jb, &c_b23, &a[j + k * + a_dim1], lda, &c_b25, &a[j + j * a_dim1], lda); + } + +/* L180: */ + } + + } + } + +/* Ran to completion, A has full rank */ + + *rank = *n; + + goto L200; +L190: + +/* Rank is the number of steps completed. Set INFO = 1 to signal */ +/* that the factorization cannot be used to solve a system. */ + + *rank = j - 1; + *info = 1; + +L200: + return 0; + +/* End of DPSTRF */ + +} /* dpstrf_ */ + diff --git a/lapack-netlib/SRC/dptcon.c b/lapack-netlib/SRC/dptcon.c new file mode 100644 index 000000000..c144afa9c --- /dev/null +++ b/lapack-netlib/SRC/dptcon.c @@ -0,0 +1,614 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPTCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) */ + +/* INTEGER INFO, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* DOUBLE PRECISION D( * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTCON computes the reciprocal of the condition number (in the */ +/* > 1-norm) of a real symmetric positive definite tridiagonal matrix */ +/* > using the factorization A = L*D*L**T or A = U**T*D*U computed by */ +/* > DPTTRF. */ +/* > */ +/* > Norm(inv(A)) is computed by a direct method, and the reciprocal of */ +/* > the condition number is computed as */ +/* > RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from the */ +/* > factorization of A, as computed by DPTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) off-diagonal elements of the unit bidiagonal factor */ +/* > U or L from the factorization of A, as computed by DPTTRF. */ +/* > \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 the */ +/* > 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doublePTcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The method used is described in Nicholas J. Higham, "Efficient */ +/* > Algorithms for Computing the Condition Number of a Tridiagonal */ +/* > Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dptcon_(integer *n, doublereal *d__, doublereal *e, + doublereal *anorm, doublereal *rcond, doublereal *work, integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + integer i__, ix; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*anorm < 0.) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTCON", &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 D(1:N) is positive. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= 0.) { + return 0; + } +/* L10: */ + } + +/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ + +/* m(i,j) = abs(A(i,j)), i = j, */ +/* m(i,j) = -abs(A(i,j)), i .ne. j, */ + +/* and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**T. */ + +/* Solve M(L) * x = e. */ + + work[1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + work[i__] = work[i__ - 1] * (d__1 = e[i__ - 1], abs(d__1)) + 1.; +/* L20: */ + } + +/* Solve D * M(L)**T * x = b. */ + + work[*n] /= d__[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + work[i__] = work[i__] / d__[i__] + work[i__ + 1] * (d__1 = e[i__], + abs(d__1)); +/* L30: */ + } + +/* Compute AINVNM = f2cmax(x(i)), 1<=i<=n. */ + + ix = idamax_(n, &work[1], &c__1); + ainvnm = (d__1 = work[ix], abs(d__1)); + +/* Compute the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + + return 0; + +/* End of DPTCON */ + +} /* dptcon_ */ + diff --git a/lapack-netlib/SRC/dpteqr.c b/lapack-netlib/SRC/dpteqr.c new file mode 100644 index 000000000..61bda00f2 --- /dev/null +++ b/lapack-netlib/SRC/dpteqr.c @@ -0,0 +1,669 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPTEQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTEQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) */ + +/* CHARACTER COMPZ */ +/* INTEGER INFO, LDZ, N */ +/* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTEQR computes all eigenvalues and, optionally, eigenvectors of a */ +/* > symmetric positive definite tridiagonal matrix by first factoring the */ +/* > matrix using DPTTRF, and then calling DBDSQR to compute the singular */ +/* > values of the bidiagonal factor. */ +/* > */ +/* > This routine computes the eigenvalues of the positive definite */ +/* > tridiagonal matrix to high relative accuracy. This means that if the */ +/* > eigenvalues range over many orders of magnitude in size, then the */ +/* > small eigenvalues and corresponding eigenvectors will be computed */ +/* > more accurately than, for example, with the standard QR method. */ +/* > */ +/* > The eigenvectors of a full or band symmetric positive definite matrix */ +/* > can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to */ +/* > reduce this matrix to tridiagonal form. (The reduction to tridiagonal */ +/* > form, however, may preclude the possibility of obtaining high */ +/* > relative accuracy in the small eigenvalues of the original matrix, if */ +/* > these eigenvalues range over many orders of magnitude.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only. */ +/* > = 'V': Compute eigenvectors of original symmetric */ +/* > matrix also. Array Z contains the orthogonal */ +/* > matrix used to reduce the original matrix to */ +/* > tridiagonal form. */ +/* > = 'I': Compute eigenvectors of tridiagonal matrix also. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On normal exit, D contains the eigenvalues, in descending */ +/* > order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', the orthogonal matrix used in the */ +/* > reduction to tridiagonal form. */ +/* > On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */ +/* > original symmetric matrix; */ +/* > if COMPZ = 'I', the orthonormal eigenvectors of the */ +/* > tridiagonal matrix. */ +/* > If INFO > 0 on exit, Z contains the eigenvectors associated */ +/* > with only the stored eigenvalues. */ +/* > If COMPZ = '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 */ +/* > COMPZ = 'V' or 'I', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N the Cholesky factorization of the matrix could */ +/* > not be performed because the i-th principal minor */ +/* > was not positive definite. */ +/* > > N the SVD algorithm failed to converge; */ +/* > if INFO = N+i, i off-diagonal elements of the */ +/* > bidiagonal factor 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 doublePTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ldz, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + doublereal c__[1] /* was [1][1] */; + integer i__; + extern logical lsame_(char *, char *); + doublereal vt[1] /* was [1][1] */; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), dbdsqr_(char *, integer *, + integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *); + integer icompz; + extern /* Subroutine */ int dpttrf_(integer *, doublereal *, doublereal *, + integer *); + integer nru; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTEQR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (icompz > 0) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + if (icompz == 2) { + dlaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz); + } + +/* Call DPTTRF to factor the matrix. */ + + dpttrf_(n, &d__[1], &e[1], info); + if (*info != 0) { + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(d__[i__]); +/* L10: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] *= d__[i__]; +/* L20: */ + } + +/* Call DBDSQR to compute the singular values/vectors of the */ +/* bidiagonal factor. */ + + if (icompz > 0) { + nru = *n; + } else { + nru = 0; + } + dbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[ + z_offset], ldz, c__, &c__1, &work[1], info); + +/* Square the singular values. */ + + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] *= d__[i__]; +/* L30: */ + } + } else { + *info = *n + *info; + } + + return 0; + +/* End of DPTEQR */ + +} /* dpteqr_ */ + diff --git a/lapack-netlib/SRC/dptrfs.c b/lapack-netlib/SRC/dptrfs.c new file mode 100644 index 000000000..a84964b73 --- /dev/null +++ b/lapack-netlib/SRC/dptrfs.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 DPTRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, */ +/* BERR, WORK, INFO ) */ + +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), */ +/* $ E( * ), EF( * ), FERR( * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is symmetric positive definite */ +/* > and tridiagonal, and provides error bounds and backward error */ +/* > estimates for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \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] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DF */ +/* > \verbatim */ +/* > DF is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from the */ +/* > factorization computed by DPTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EF */ +/* > \verbatim */ +/* > EF is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the unit bidiagonal factor */ +/* > L from the factorization computed by DPTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by DPTTRS. */ +/* > 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 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). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (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 */ + +/* > \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 doublePTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, doublereal *d__, + doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer + *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, + doublereal *work, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + doublereal d__1, d__2, d__3; + + /* Local variables */ + doublereal safe1, safe2; + integer i__, j; + doublereal s; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + integer count; + doublereal bi; + extern doublereal dlamch_(char *); + doublereal cx, dx, ex; + integer ix; + extern integer idamax_(integer *, doublereal *, integer *); + integer nz; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal lstres; + extern /* Subroutine */ int dpttrs_(integer *, integer *, doublereal *, + doublereal *, doublereal *, 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 */ + --d__; + --e; + --df; + --ef; + 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; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldx < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTRFS", &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 = 4; + 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. Also compute */ +/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */ + + if (*n == 1) { + bi = b[j * b_dim1 + 1]; + dx = d__[1] * x[j * x_dim1 + 1]; + work[*n + 1] = bi - dx; + work[1] = abs(bi) + abs(dx); + } else { + bi = b[j * b_dim1 + 1]; + dx = d__[1] * x[j * x_dim1 + 1]; + ex = e[1] * x[j * x_dim1 + 2]; + work[*n + 1] = bi - dx - ex; + work[1] = abs(bi) + abs(dx) + abs(ex); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + bi = b[i__ + j * b_dim1]; + cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1]; + dx = d__[i__] * x[i__ + j * x_dim1]; + ex = e[i__] * x[i__ + 1 + j * x_dim1]; + work[*n + i__] = bi - cx - dx - ex; + work[i__] = abs(bi) + abs(cx) + abs(dx) + abs(ex); +/* L30: */ + } + bi = b[*n + j * b_dim1]; + cx = e[*n - 1] * x[*n - 1 + j * x_dim1]; + dx = d__[*n] * x[*n + j * x_dim1]; + work[*n + *n] = bi - cx - dx; + work[*n] = abs(bi) + abs(cx) + abs(dx); + } + +/* 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. */ + + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = f2cmax(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(d__2,d__3); + } +/* L40: */ + } + 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. */ + + dpttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info); + daxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(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. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L50: */ + } + ix = idamax_(n, &work[1], &c__1); + ferr[j] = work[ix]; + +/* Estimate the norm of inv(A). */ + +/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ + +/* m(i,j) = abs(A(i,j)), i = j, */ +/* m(i,j) = -abs(A(i,j)), i .ne. j, */ + +/* and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**T. */ + +/* Solve M(L) * x = e. */ + + work[1] = 1.; + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__] = work[i__ - 1] * (d__1 = ef[i__ - 1], abs(d__1)) + 1.; +/* L60: */ + } + +/* Solve D * M(L)**T * x = b. */ + + work[*n] /= df[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + work[i__] = work[i__] / df[i__] + work[i__ + 1] * (d__1 = ef[i__], + abs(d__1)); +/* L70: */ + } + +/* Compute norm(inv(A)) = f2cmax(x(i)), 1<=i<=n. */ + + ix = idamax_(n, &work[1], &c__1); + ferr[j] *= (d__1 = work[ix], abs(d__1)); + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = f2cmax(d__2,d__3); +/* L80: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L90: */ + } + + return 0; + +/* End of DPTRFS */ + +} /* dptrfs_ */ + diff --git a/lapack-netlib/SRC/dptsv.c b/lapack-netlib/SRC/dptsv.c new file mode 100644 index 000000000..28f06c304 --- /dev/null +++ b/lapack-netlib/SRC/dptsv.c @@ -0,0 +1,562 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DPTSV computes the solution to system of linear equations A * X = B for PT matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) */ + +/* INTEGER INFO, LDB, N, NRHS */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTSV computes the solution to a real system of linear equations */ +/* > A*X = B, where A is an N-by-N symmetric positive definite tridiagonal */ +/* > matrix, and X and B are N-by-NRHS matrices. */ +/* > */ +/* > A is factored as A = L*D*L**T, and the factored form of A is then */ +/* > used to solve the system of equations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. On exit, the n diagonal elements of the diagonal matrix */ +/* > D from the factorization A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A. On exit, the (n-1) subdiagonal elements of the */ +/* > unit bidiagonal factor L from the L*D*L**T factorization of */ +/* > A. (E can also be regarded as the superdiagonal of the unit */ +/* > bidiagonal factor U from the U**T*D*U factorization of A.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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, the leading minor of order i is not */ +/* > positive definite, and the solution has not been */ +/* > computed. The factorization has not been completed */ +/* > unless i = N. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doublePTsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dptsv_(integer *n, integer *nrhs, doublereal *d__, + doublereal *e, doublereal *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpttrf_( + integer *, doublereal *, doublereal *, integer *), dpttrs_( + integer *, integer *, doublereal *, doublereal *, doublereal *, + 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 */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the L*D*L**T (or U**T*D*U) factorization of A. */ + + dpttrf_(n, &d__[1], &e[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dpttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info); + } + return 0; + +/* End of DPTSV */ + +} /* dptsv_ */ + diff --git a/lapack-netlib/SRC/dptsvx.c b/lapack-netlib/SRC/dptsvx.c new file mode 100644 index 000000000..172c324da --- /dev/null +++ b/lapack-netlib/SRC/dptsvx.c @@ -0,0 +1,744 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DPTSVX computes the solution to system of linear equations A * X = B for PT matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, */ +/* RCOND, FERR, BERR, WORK, INFO ) */ + +/* CHARACTER FACT */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION RCOND */ +/* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), */ +/* $ E( * ), EF( * ), FERR( * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTSVX uses the factorization A = L*D*L**T to compute the solution */ +/* > to a real system of linear equations A*X = B, where A is an N-by-N */ +/* > symmetric positive definite tridiagonal matrix 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 matrix A is factored as A = L*D*L**T, where L */ +/* > is a unit lower bidiagonal matrix and D is diagonal. The */ +/* > factorization can also be regarded as having the form */ +/* > A = U**T*D*U. */ +/* > */ +/* > 2. If the leading i-by-i principal minor is not positive definite, */ +/* > 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, DF and EF contain the factored form of A. */ +/* > D, E, DF, and EF will not be modified. */ +/* > = 'N': The matrix A will be copied to DF and EF and */ +/* > factored. */ +/* > \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] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DF */ +/* > \verbatim */ +/* > DF is DOUBLE PRECISION array, dimension (N) */ +/* > If FACT = 'F', then DF is an input argument and on entry */ +/* > contains the n diagonal elements of the diagonal matrix D */ +/* > from the L*D*L**T factorization of A. */ +/* > If FACT = 'N', then DF is an output argument and on exit */ +/* > contains the n diagonal elements of the diagonal matrix D */ +/* > from the L*D*L**T factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EF */ +/* > \verbatim */ +/* > EF is DOUBLE PRECISION array, dimension (N-1) */ +/* > If FACT = 'F', then EF is an input argument and on entry */ +/* > contains the (n-1) subdiagonal elements of the unit */ +/* > bidiagonal factor L from the L*D*L**T factorization of A. */ +/* > If FACT = 'N', then EF is an output argument and on exit */ +/* > contains the (n-1) subdiagonal elements of the unit */ +/* > bidiagonal factor L from the L*D*L**T factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > If INFO = 0 of 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 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 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). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in any */ +/* > element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the leading minor of order i of A is */ +/* > not positive definite, so the factorization */ +/* > could not be completed, and the solution has not */ +/* > been computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doublePTsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dptsvx_(char *fact, integer *n, integer *nrhs, + doublereal *d__, doublereal *e, doublereal *df, doublereal *ef, + doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * + rcond, doublereal *ferr, doublereal *berr, doublereal *work, 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 dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + extern doublereal dlamch_(char *); + logical nofact; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dptcon_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *), dptrfs_( + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *), dpttrf_( + integer *, doublereal *, doublereal *, integer *), dpttrs_( + integer *, integer *, doublereal *, doublereal *, doublereal *, + 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 */ + --d__; + --e; + --df; + --ef; + 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; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTSVX", &i__1, (ftnlen)6); + return 0; + } + + if (nofact) { + +/* Compute the L*D*L**T (or U**T*D*U) factorization of A. */ + + dcopy_(n, &d__[1], &c__1, &df[1], &c__1); + if (*n > 1) { + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &ef[1], &c__1); + } + dpttrf_(n, &df[1], &ef[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlanst_("1", n, &d__[1], &e[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dpttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + dptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[ + x_offset], ldx, &ferr[1], &berr[1], &work[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 DPTSVX */ + +} /* dptsvx_ */ + diff --git a/lapack-netlib/SRC/dpttrf.c b/lapack-netlib/SRC/dpttrf.c new file mode 100644 index 000000000..60a84fb67 --- /dev/null +++ b/lapack-netlib/SRC/dpttrf.c @@ -0,0 +1,600 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPTTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTTRF( N, D, E, INFO ) */ + +/* INTEGER INFO, N */ +/* DOUBLE PRECISION D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTTRF computes the L*D*L**T factorization of a real symmetric */ +/* > positive definite tridiagonal matrix A. The factorization may also */ +/* > be regarded as having the form A = U**T*D*U. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. On exit, the n diagonal elements of the diagonal matrix */ +/* > D from the L*D*L**T factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A. On exit, the (n-1) subdiagonal elements of the */ +/* > unit bidiagonal factor L from the L*D*L**T factorization of A. */ +/* > E can also be regarded as the superdiagonal of the unit */ +/* > bidiagonal factor U from the U**T*D*U factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, the leading minor of order k is not */ +/* > positive definite; if k < N, the factorization could not */ +/* > be completed, while if k = N, the factorization was */ +/* > completed, but D(N) <= 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doublePTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dpttrf_(integer *n, doublereal *d__, doublereal *e, + integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, i4; + doublereal ei; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("DPTTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Compute the L*D*L**T (or U**T*D*U) factorization of A. */ + + i4 = (*n - 1) % 4; + i__1 = i4; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= 0.) { + *info = i__; + goto L30; + } + ei = e[i__]; + e[i__] = ei / d__[i__]; + d__[i__ + 1] -= e[i__] * ei; +/* L10: */ + } + + i__1 = *n - 4; + for (i__ = i4 + 1; i__ <= i__1; i__ += 4) { + +/* Drop out of the loop if d(i) <= 0: the matrix is not positive */ +/* definite. */ + + if (d__[i__] <= 0.) { + *info = i__; + goto L30; + } + +/* Solve for e(i) and d(i+1). */ + + ei = e[i__]; + e[i__] = ei / d__[i__]; + d__[i__ + 1] -= e[i__] * ei; + + if (d__[i__ + 1] <= 0.) { + *info = i__ + 1; + goto L30; + } + +/* Solve for e(i+1) and d(i+2). */ + + ei = e[i__ + 1]; + e[i__ + 1] = ei / d__[i__ + 1]; + d__[i__ + 2] -= e[i__ + 1] * ei; + + if (d__[i__ + 2] <= 0.) { + *info = i__ + 2; + goto L30; + } + +/* Solve for e(i+2) and d(i+3). */ + + ei = e[i__ + 2]; + e[i__ + 2] = ei / d__[i__ + 2]; + d__[i__ + 3] -= e[i__ + 2] * ei; + + if (d__[i__ + 3] <= 0.) { + *info = i__ + 3; + goto L30; + } + +/* Solve for e(i+3) and d(i+4). */ + + ei = e[i__ + 3]; + e[i__ + 3] = ei / d__[i__ + 3]; + d__[i__ + 4] -= e[i__ + 3] * ei; +/* L20: */ + } + +/* Check d(n) for positive definiteness. */ + + if (d__[*n] <= 0.) { + *info = *n; + } + +L30: + return 0; + +/* End of DPTTRF */ + +} /* dpttrf_ */ + diff --git a/lapack-netlib/SRC/dpttrs.c b/lapack-netlib/SRC/dpttrs.c new file mode 100644 index 000000000..65fd8b8e2 --- /dev/null +++ b/lapack-netlib/SRC/dpttrs.c @@ -0,0 +1,585 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPTTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) */ + +/* INTEGER INFO, LDB, N, NRHS */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTTRS solves a tridiagonal system of the form */ +/* > A * X = B */ +/* > using the L*D*L**T factorization of A computed by DPTTRF. D is a */ +/* > diagonal matrix specified in the vector D, L is a unit bidiagonal */ +/* > matrix whose subdiagonal is specified in the vector E, and X and B */ +/* > are N by NRHS matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the tridiagonal 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] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from the */ +/* > L*D*L**T factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the unit bidiagonal factor */ +/* > L from the L*D*L**T factorization of A. E can also be regarded */ +/* > as the superdiagonal of the unit bidiagonal factor U from the */ +/* > factorization A = U**T*D*U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side vectors B for the system of */ +/* > linear equations. */ +/* > On exit, the solution vectors, 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 = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doublePTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dpttrs_(integer *n, integer *nrhs, doublereal *d__, + doublereal *e, doublereal *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer j, jb, nb; + extern /* Subroutine */ int dptts2_(integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Determine the number of right-hand sides to solve at a time. */ + + if (*nrhs == 1) { + nb = 1; + } else { +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "DPTTRS", " ", n, nrhs, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + nb = f2cmax(i__1,i__2); + } + + if (nb >= *nrhs) { + dptts2_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb); + } else { + i__1 = *nrhs; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nrhs - j + 1; + jb = f2cmin(i__3,nb); + dptts2_(n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb); +/* L10: */ + } + } + + return 0; + +/* End of DPTTRS */ + +} /* dpttrs_ */ + diff --git a/lapack-netlib/SRC/dptts2.c b/lapack-netlib/SRC/dptts2.c new file mode 100644 index 000000000..b2682f4fd --- /dev/null +++ b/lapack-netlib/SRC/dptts2.c @@ -0,0 +1,561 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DPTTS2 solves a tridiagonal system of the form AX=B using the L D LH factorization computed by +spttrf. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DPTTS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) */ + +/* INTEGER LDB, N, NRHS */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DPTTS2 solves a tridiagonal system of the form */ +/* > A * X = B */ +/* > using the L*D*L**T factorization of A computed by DPTTRF. D is a */ +/* > diagonal matrix specified in the vector D, L is a unit bidiagonal */ +/* > matrix whose subdiagonal is specified in the vector E, and X and B */ +/* > are N by NRHS matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the tridiagonal 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] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from the */ +/* > L*D*L**T factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the unit bidiagonal factor */ +/* > L from the L*D*L**T factorization of A. E can also be regarded */ +/* > as the superdiagonal of the unit bidiagonal factor U from the */ +/* > factorization A = U**T*D*U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side vectors B for the system of */ +/* > linear equations. */ +/* > On exit, the solution vectors, X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doublePTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dptts2_(integer *n, integer *nrhs, doublereal *d__, + doublereal *e, doublereal *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (*n <= 1) { + if (*n == 1) { + d__1 = 1. / d__[1]; + dscal_(nrhs, &d__1, &b[b_offset], ldb); + } + return 0; + } + +/* Solve A * X = B using the factorization A = L*D*L**T, */ +/* overwriting each right hand side vector with its solution. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve L * x = b. */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= b[i__ - 1 + j * b_dim1] * e[i__ - 1]; +/* L10: */ + } + +/* Solve D * L**T * x = b. */ + + b[*n + j * b_dim1] /= d__[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] / d__[i__] - b[i__ + 1 + + j * b_dim1] * e[i__]; +/* L20: */ + } +/* L30: */ + } + + return 0; + +/* End of DPTTS2 */ + +} /* dptts2_ */ + diff --git a/lapack-netlib/SRC/drscl.c b/lapack-netlib/SRC/drscl.c new file mode 100644 index 000000000..e511f2501 --- /dev/null +++ b/lapack-netlib/SRC/drscl.c @@ -0,0 +1,552 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DRSCL multiplies a vector by the reciprocal of a real scalar. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DRSCL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DRSCL( N, SA, SX, INCX ) */ + +/* INTEGER INCX, N */ +/* DOUBLE PRECISION SA */ +/* DOUBLE PRECISION SX( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DRSCL multiplies an n-element real vector x by the real scalar 1/a. */ +/* > This is done without overflow or underflow as long as */ +/* > the final result x/a does not overflow or underflow. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of components of the vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SA */ +/* > \verbatim */ +/* > SA is DOUBLE PRECISION */ +/* > The scalar a which is used to divide each component of x. */ +/* > SA must be >= 0, or the subroutine will divide by zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SX */ +/* > \verbatim */ +/* > SX is DOUBLE PRECISION array, dimension */ +/* > (1+(N-1)*abs(INCX)) */ +/* > The n-element vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of the vector SX. */ +/* > > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx, + integer *incx) +{ + doublereal cden; + logical done; + doublereal cnum, cden1, cnum1; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dlabad_(doublereal *, doublereal *); + extern doublereal dlamch_(char *); + doublereal bignum, smlnum, mul; + + +/* -- LAPACK auxiliary routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Initialize the denominator to SA and the numerator to 1. */ + + cden = *sa; + cnum = 1.; + +L10: + cden1 = cden * smlnum; + cnum1 = cnum / bignum; + if (abs(cden1) > abs(cnum) && cnum != 0.) { + +/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ + + mul = smlnum; + done = FALSE_; + cden = cden1; + } else if (abs(cnum1) > abs(cden)) { + +/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ + + mul = bignum; + done = FALSE_; + cnum = cnum1; + } else { + +/* Multiply X by CNUM / CDEN and return. */ + + mul = cnum / cden; + done = TRUE_; + } + +/* Scale the vector X by MUL */ + + dscal_(n, &mul, &sx[1], incx); + + if (! done) { + goto L10; + } + + return 0; + +/* End of DRSCL */ + +} /* drscl_ */ + diff --git a/lapack-netlib/SRC/dsb2st_kernels.c b/lapack-netlib/SRC/dsb2st_kernels.c new file mode 100644 index 000000000..e65cf495d --- /dev/null +++ b/lapack-netlib/SRC/dsb2st_kernels.c @@ -0,0 +1,780 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSB2ST_KERNELS */ + +/* @generated from zhb2st_kernels.f, fortran z -> d, Wed Dec 7 08:22:39 2016 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSB2ST_KERNELS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSB2ST_KERNELS( UPLO, WANTZ, TTYPE, */ +/* ST, ED, SWEEP, N, NB, IB, */ +/* A, LDA, V, TAU, LDVT, WORK) */ + +/* IMPLICIT NONE */ + +/* CHARACTER UPLO */ +/* LOGICAL WANTZ */ +/* INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT */ +/* DOUBLE PRECISION A( LDA, * ), V( * ), */ +/* TAU( * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSB2ST_KERNELS is an internal routine used by the DSYTRD_SB2ST */ +/* > subroutine. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL which indicate if Eigenvalue are requested or both */ +/* > Eigenvalue/Eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TTYPE */ +/* > \verbatim */ +/* > TTYPE is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ST */ +/* > \verbatim */ +/* > ST is INTEGER */ +/* > internal parameter for indices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ED */ +/* > \verbatim */ +/* > ED is INTEGER */ +/* > internal parameter for indices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SWEEP */ +/* > \verbatim */ +/* > SWEEP is INTEGER */ +/* > internal parameter for indices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER. The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER. The size of the band. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IB */ +/* > \verbatim */ +/* > IB is INTEGER. */ +/* > \endverbatim */ +/* > */ +/* > \param[in, out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array. A pointer to the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER. The leading dimension of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension 2*n if eigenvalues only are */ +/* > requested or to be queried for vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (2*n). */ +/* > The scalar factors of the Householder reflectors are stored */ +/* > in this array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array. Workspace of size nb. */ +/* > \endverbatim */ +/* > */ +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Implemented by Azzam Haidar. */ +/* > */ +/* > All details are available on technical report, SC11, SC13 papers. */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsb2st_kernels_(char *uplo, logical *wantz, integer * + ttype, integer *st, integer *ed, integer *sweep, integer *n, integer * + nb, integer *ib, doublereal *a, integer *lda, doublereal *v, + doublereal *tau, integer *ldvt, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal ctmp; + integer dpos, vpos, i__; + extern logical lsame_(char *, char *); + logical upper; + integer j1, j2, lm, ln; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *); + integer ajeter; + extern /* Subroutine */ int dlarfx_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *), dlarfy_(char *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *); + integer ofdpos, taupos; + + + +/* -- 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; + --v; + --tau; + --work; + + /* Function Body */ + ajeter = *ib + *ldvt; + upper = lsame_(uplo, "U"); + if (upper) { + dpos = (*nb << 1) + 1; + ofdpos = *nb << 1; + } else { + dpos = 1; + ofdpos = 2; + } + +/* Upper case */ + + if (upper) { + + if (*wantz) { + vpos = (*sweep - 1) % 2 * *n + *st; + taupos = (*sweep - 1) % 2 * *n + *st; + } else { + vpos = (*sweep - 1) % 2 * *n + *st; + taupos = (*sweep - 1) % 2 * *n + *st; + } + + if (*ttype == 1) { + lm = *ed - *st + 1; + + v[vpos] = 1.; + i__1 = lm - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + v[vpos + i__] = a[ofdpos - i__ + (*st + i__) * a_dim1]; + a[ofdpos - i__ + (*st + i__) * a_dim1] = 0.; +/* L10: */ + } + ctmp = a[ofdpos + *st * a_dim1]; + dlarfg_(&lm, &ctmp, &v[vpos + 1], &c__1, &tau[taupos]); + a[ofdpos + *st * a_dim1] = ctmp; + + lm = *ed - *st + 1; + d__1 = tau[taupos]; + i__1 = *lda - 1; + dlarfy_(uplo, &lm, &v[vpos], &c__1, &d__1, &a[dpos + *st * a_dim1] + , &i__1, &work[1]); + } + + if (*ttype == 3) { + + lm = *ed - *st + 1; + d__1 = tau[taupos]; + i__1 = *lda - 1; + dlarfy_(uplo, &lm, &v[vpos], &c__1, &d__1, &a[dpos + *st * a_dim1] + , &i__1, &work[1]); + } + + if (*ttype == 2) { + j1 = *ed + 1; +/* Computing MIN */ + i__1 = *ed + *nb; + j2 = f2cmin(i__1,*n); + ln = *ed - *st + 1; + lm = j2 - j1 + 1; + if (lm > 0) { + d__1 = tau[taupos]; + i__1 = *lda - 1; + dlarfx_("Left", &ln, &lm, &v[vpos], &d__1, &a[dpos - *nb + j1 + * a_dim1], &i__1, &work[1]); + + if (*wantz) { + vpos = (*sweep - 1) % 2 * *n + j1; + taupos = (*sweep - 1) % 2 * *n + j1; + } else { + vpos = (*sweep - 1) % 2 * *n + j1; + taupos = (*sweep - 1) % 2 * *n + j1; + } + + v[vpos] = 1.; + i__1 = lm - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + v[vpos + i__] = a[dpos - *nb - i__ + (j1 + i__) * a_dim1]; + a[dpos - *nb - i__ + (j1 + i__) * a_dim1] = 0.; +/* L30: */ + } + ctmp = a[dpos - *nb + j1 * a_dim1]; + dlarfg_(&lm, &ctmp, &v[vpos + 1], &c__1, &tau[taupos]); + a[dpos - *nb + j1 * a_dim1] = ctmp; + + i__1 = ln - 1; + i__2 = *lda - 1; + dlarfx_("Right", &i__1, &lm, &v[vpos], &tau[taupos], &a[dpos + - *nb + 1 + j1 * a_dim1], &i__2, &work[1]); + } + } + +/* Lower case */ + + } else { + + if (*wantz) { + vpos = (*sweep - 1) % 2 * *n + *st; + taupos = (*sweep - 1) % 2 * *n + *st; + } else { + vpos = (*sweep - 1) % 2 * *n + *st; + taupos = (*sweep - 1) % 2 * *n + *st; + } + + if (*ttype == 1) { + lm = *ed - *st + 1; + + v[vpos] = 1.; + i__1 = lm - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + v[vpos + i__] = a[ofdpos + i__ + (*st - 1) * a_dim1]; + a[ofdpos + i__ + (*st - 1) * a_dim1] = 0.; +/* L20: */ + } + dlarfg_(&lm, &a[ofdpos + (*st - 1) * a_dim1], &v[vpos + 1], &c__1, + &tau[taupos]); + + lm = *ed - *st + 1; + + d__1 = tau[taupos]; + i__1 = *lda - 1; + dlarfy_(uplo, &lm, &v[vpos], &c__1, &d__1, &a[dpos + *st * a_dim1] + , &i__1, &work[1]); + } + + if (*ttype == 3) { + lm = *ed - *st + 1; + + d__1 = tau[taupos]; + i__1 = *lda - 1; + dlarfy_(uplo, &lm, &v[vpos], &c__1, &d__1, &a[dpos + *st * a_dim1] + , &i__1, &work[1]); + } + + if (*ttype == 2) { + j1 = *ed + 1; +/* Computing MIN */ + i__1 = *ed + *nb; + j2 = f2cmin(i__1,*n); + ln = *ed - *st + 1; + lm = j2 - j1 + 1; + + if (lm > 0) { + i__1 = *lda - 1; + dlarfx_("Right", &lm, &ln, &v[vpos], &tau[taupos], &a[dpos + * + nb + *st * a_dim1], &i__1, &work[1]); + + if (*wantz) { + vpos = (*sweep - 1) % 2 * *n + j1; + taupos = (*sweep - 1) % 2 * *n + j1; + } else { + vpos = (*sweep - 1) % 2 * *n + j1; + taupos = (*sweep - 1) % 2 * *n + j1; + } + + v[vpos] = 1.; + i__1 = lm - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + v[vpos + i__] = a[dpos + *nb + i__ + *st * a_dim1]; + a[dpos + *nb + i__ + *st * a_dim1] = 0.; +/* L40: */ + } + dlarfg_(&lm, &a[dpos + *nb + *st * a_dim1], &v[vpos + 1], & + c__1, &tau[taupos]); + + i__1 = ln - 1; + d__1 = tau[taupos]; + i__2 = *lda - 1; + dlarfx_("Left", &lm, &i__1, &v[vpos], &d__1, &a[dpos + *nb - + 1 + (*st + 1) * a_dim1], &i__2, &work[1]); + } + } + } + + return 0; + +/* END OF DSB2ST_KERNELS */ + +} /* dsb2st_kernels__ */ + diff --git a/lapack-netlib/SRC/dsbev.c b/lapack-netlib/SRC/dsbev.c new file mode 100644 index 000000000..8b982be7f --- /dev/null +++ b/lapack-netlib/SRC/dsbev.c @@ -0,0 +1,705 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSBEV 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 DSBEV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, */ +/* INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, KD, LDAB, LDZ, N */ +/* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBEV computes all the eigenvalues and, optionally, eigenvectors of */ +/* > a real symmetric band matrix A. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, AB is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the first */ +/* > superdiagonal and the diagonal of the tridiagonal matrix T */ +/* > are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* > the diagonal and first subdiagonal of T are returned in the */ +/* > first two rows of AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD + 1. */ +/* > \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 DOUBLE PRECISION 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 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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dsbev_(char *jobz, char *uplo, integer *n, integer *kd, + doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, 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 lower, wantz; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dsterf_( + integer *, doublereal *, doublereal *, integer *); + integer indwrk; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + doublereal smlnum, 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEV ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (lower) { + w[1] = ab[ab_dim1 + 1]; + } else { + w[1] = ab[*kd + 1 + ab_dim1]; + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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 = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[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) { + if (lower) { + dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + } + +/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ + + inde = 1; + indwrk = inde + *n; + dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ + indwrk], 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 DSBEV */ + +} /* dsbev_ */ + diff --git a/lapack-netlib/SRC/dsbev_2stage.c b/lapack-netlib/SRC/dsbev_2stage.c new file mode 100644 index 000000000..de64b5f68 --- /dev/null +++ b/lapack-netlib/SRC/dsbev_2stage.c @@ -0,0 +1,808 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for +OTHER matrices */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBEV_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, */ +/* WORK, LWORK, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, KD, LDAB, LDZ, N, LWORK */ +/* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBEV_2STAGE computes all the eigenvalues and, optionally, eigenvectors of */ +/* > a real symmetric band matrix A using the 2stage technique for */ +/* > the reduction to tridiagonal. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > Not available in this release. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, AB is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the first */ +/* > superdiagonal and the diagonal of the tridiagonal matrix T */ +/* > are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* > the diagonal and first subdiagonal of T are returned in the */ +/* > first two rows of AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD + 1. */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension LWORK */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* > otherwise */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, dimension) where */ +/* > dimension = (2KD+1)*N + KD*NTHREADS + N */ +/* > where KD is the size of the band. */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the 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 November 2017 */ + +/* > \ingroup doubleOTHEReigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsbev_2stage_(char *jobz, char *uplo, integer *n, + integer *kd, doublereal *ab, integer *ldab, doublereal *w, doublereal + *z__, integer *ldz, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, z_dim1, z_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer inde; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + doublereal anrm; + integer imax; + doublereal rmin, rmax; + extern /* Subroutine */ int dsytrd_sb2st_(char *, char *, char *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *), dscal_(integer *, doublereal * + , doublereal *, integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo, lhtrd, lwmin; + logical lower; + integer lwtrd; + logical wantz; + integer ib; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + integer indwrk; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer llwork; + doublereal smlnum; + logical lquery; + doublereal eps; + integer indhous; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1; + + *info = 0; + if (! lsame_(jobz, "N")) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + work[1] = (doublereal) lwmin; + } else { + ib = ilaenv2stage_(&c__2, "DSYTRD_SB2ST", jobz, n, kd, &c_n1, & + c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_SB2ST", jobz, n, kd, &ib, & + c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_SB2ST", jobz, n, kd, &ib, & + c_n1); + lwmin = *n + lhtrd + lwtrd; + work[1] = (doublereal) lwmin; + } + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEV_2STAGE ", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (lower) { + w[1] = ab[ab_dim1 + 1]; + } else { + w[1] = ab[*kd + 1 + ab_dim1]; + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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 = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[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) { + if (lower) { + dlascl_("B", kd, kd, &c_b21, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b21, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + } + +/* Call DSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. */ + + inde = 1; + indhous = inde + *n; + indwrk = indhous + lhtrd; + llwork = *lwork - indwrk + 1; + + dsytrd_sb2st_("N", jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[ + inde], &work[indhous], &lhtrd, &work[indwrk], &llwork, &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ + indwrk], 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); + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwmin; + + return 0; + +/* End of DSBEV_2STAGE */ + +} /* dsbev_2stage__ */ + diff --git a/lapack-netlib/SRC/dsbevd.c b/lapack-netlib/SRC/dsbevd.c new file mode 100644 index 000000000..87e6d3ded --- /dev/null +++ b/lapack-netlib/SRC/dsbevd.c @@ -0,0 +1,786 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSBEVD 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 DSBEVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, */ +/* LWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBEVD computes all the eigenvalues and, optionally, eigenvectors of */ +/* > a real symmetric band matrix A. 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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, AB is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the first */ +/* > superdiagonal and the diagonal of the tridiagonal matrix T */ +/* > are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* > the diagonal and first subdiagonal of T are returned in the */ +/* > first two rows of AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD + 1. */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, */ +/* > dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > IF N <= 1, LWORK must be at least 1. */ +/* > If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. */ +/* > If JOBZ = 'V' and N > 2, LWORK must be at least */ +/* > ( 1 + 5*N + 2*N**2 ). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ +/* > If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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 December 2016 */ + +/* > \ingroup doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dsbevd_(char *jobz, char *uplo, integer *n, integer *kd, + doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, integer *lwork, integer *iwork, + integer *liwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, z_dim1, z_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer inde; + doublereal anrm, rmin, rmax; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemm_(char *, char *, integer *, integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo, lwmin; + logical lower, wantz; + integer indwk2, llwrk2; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *, integer *, integer *), dlacpy_(char *, integer + *, integer *, doublereal *, integer *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dsterf_( + integer *, doublereal *, doublereal *, integer *); + integer indwrk, liwmin; + doublereal smlnum; + logical lquery; + 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = *n << 1; + } + } + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info == 0) { + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEVD", &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] = ab[ab_dim1 + 1]; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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 = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[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) { + if (lower) { + dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + } + +/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ + + inde = 1; + indwrk = inde + *n; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk], + n, &c_b18, &work[indwk2], n); + dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSBEVD */ + +} /* dsbevd_ */ + diff --git a/lapack-netlib/SRC/dsbevd_2stage.c b/lapack-netlib/SRC/dsbevd_2stage.c new file mode 100644 index 000000000..564602274 --- /dev/null +++ b/lapack-netlib/SRC/dsbevd_2stage.c @@ -0,0 +1,846 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for + OTHER matrices */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBEVD_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, */ +/* WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBEVD_2STAGE computes all the eigenvalues and, optionally, eigenvectors of */ +/* > a real symmetric band matrix A using the 2stage technique for */ +/* > the reduction to tridiagonal. 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. */ +/* > Not available in this release. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, AB is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the first */ +/* > superdiagonal and the diagonal of the tridiagonal matrix T */ +/* > are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* > the diagonal and first subdiagonal of T are returned in the */ +/* > first two rows of AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD + 1. */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension LWORK */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* > otherwise */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, dimension) where */ +/* > dimension = (2KD+1)*N + KD*NTHREADS + N */ +/* > where KD is the size of the band. */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ +/* > If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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 November 2017 */ + +/* > \ingroup doubleOTHEReigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsbevd_2stage_(char *jobz, char *uplo, integer *n, + integer *kd, doublereal *ab, integer *ldab, doublereal *w, doublereal + *z__, integer *ldz, doublereal *work, integer *lwork, integer *iwork, + integer *liwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, z_dim1, z_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer inde; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + doublereal anrm, rmin, rmax; + extern /* Subroutine */ int dsytrd_sb2st_(char *, char *, char *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *), dscal_(integer *, doublereal * + , doublereal *, integer *), dgemm_(char *, char *, integer *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo, lhtrd, lwmin; + logical lower; + integer lwtrd; + logical wantz; + integer indwk2, ib, llwrk2; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *, integer *, integer *), dlacpy_(char *, integer + *, integer *, doublereal *, integer *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + integer indwrk, liwmin, llwork; + doublereal smlnum; + logical lquery; + doublereal eps; + integer indhous; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else { + ib = ilaenv2stage_(&c__2, "DSYTRD_SB2ST", jobz, n, kd, &c_n1, &c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_SB2ST", jobz, n, kd, &ib, &c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_SB2ST", jobz, n, kd, &ib, &c_n1); + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; +/* Computing MAX */ + i__1 = *n << 1, i__2 = *n + lhtrd + lwtrd; + lwmin = f2cmax(i__1,i__2); + } + } + if (! lsame_(jobz, "N")) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info == 0) { + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEVD_2STAGE", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = ab[ab_dim1 + 1]; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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 = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[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) { + if (lower) { + dlascl_("B", kd, kd, &c_b21, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b21, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + } + +/* Call DSYTRD_SB2ST to reduce band symmetric matrix to tridiagonal form. */ + + inde = 1; + indhous = inde + *n; + indwrk = indhous + lhtrd; + llwork = *lwork - indwrk + 1; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + + dsytrd_sb2st_("N", jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[ + inde], &work[indhous], &lhtrd, &work[indwrk], &llwork, &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dgemm_("N", "N", n, n, n, &c_b21, &z__[z_offset], ldz, &work[indwrk], + n, &c_b29, &work[indwk2], n); + dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSBEVD_2STAGE */ + +} /* dsbevd_2stage__ */ + diff --git a/lapack-netlib/SRC/dsbevx.c b/lapack-netlib/SRC/dsbevx.c new file mode 100644 index 000000000..e126ec947 --- /dev/null +++ b/lapack-netlib/SRC/dsbevx.c @@ -0,0 +1,1003 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSBEVX 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 DSBEVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, */ +/* VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, */ +/* IFAIL, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric band matrix A. 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] 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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, AB is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the first */ +/* > superdiagonal and the diagonal of the tridiagonal matrix T */ +/* > are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* > the diagonal and first subdiagonal of T are returned in the */ +/* > first two rows of AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD + 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */ +/* > If JOBZ = 'V', the N-by-N orthogonal matrix used in the */ +/* > reduction to tridiagonal form. */ +/* > If JOBZ = 'N', the array Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. If JOBZ = 'V', then */ +/* > LDQ >= f2cmax(1,N). */ +/* > \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 AB 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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n, + integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer * + ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu, + doublereal *abstol, integer *m, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, integer *iwork, integer *ifail, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, q_dim1, q_offset, 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 *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer iinfo; + char order[1]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + logical lower, wantz; + integer jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, indibl; + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + logical valeig; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal abstll, bignum; + extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + integer indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo; + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *); + integer indwrk; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer nsplit; + doublereal smlnum, 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lower = lsame_(uplo, "L"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } else if (wantz && *ldq < f2cmax(1,*n)) { + *info = -9; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -11; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -12; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -13; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -18; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEVX", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + *m = 1; + if (lower) { + tmp1 = ab[ab_dim1 + 1]; + } else { + tmp1 = ab[*kd + 1 + ab_dim1]; + } + if (valeig) { + if (! (*vl < tmp1 && *vu >= tmp1)) { + *m = 0; + } + } + if (*m == 1) { + w[1] = tmp1; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + } + 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 = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ + + indd = 1; + inde = indd + *n; + indwrk = inde + *n; + dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde], + &q[q_offset], ldq, &work[indwrk], &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1); + dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, & + c_b34, &z__[j * z_dim1 + 1], &c__1); +/* L20: */ + } + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L30: + 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]; + } +/* L40: */ + } + + 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; + dswap_(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; + } + } +/* L50: */ + } + } + + return 0; + +/* End of DSBEVX */ + +} /* dsbevx_ */ + diff --git a/lapack-netlib/SRC/dsbevx_2stage.c b/lapack-netlib/SRC/dsbevx_2stage.c new file mode 100644 index 000000000..c20d93122 --- /dev/null +++ b/lapack-netlib/SRC/dsbevx_2stage.c @@ -0,0 +1,1107 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for + OTHER matrices */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBEVX_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, */ +/* LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, */ +/* LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric band matrix A using the 2stage technique for */ +/* > the reduction to tridiagonal. 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] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > Not available in this release. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, AB is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the first */ +/* > superdiagonal and the diagonal of the tridiagonal matrix T */ +/* > are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* > the diagonal and first subdiagonal of T are returned in the */ +/* > first two rows of AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD + 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */ +/* > If JOBZ = 'V', the N-by-N orthogonal matrix used in the */ +/* > reduction to tridiagonal form. */ +/* > If JOBZ = 'N', the array Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. If JOBZ = 'V', then */ +/* > LDQ >= f2cmax(1,N). */ +/* > \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 AB 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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* > otherwise */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, 7*N, dimension) where */ +/* > dimension = (2KD+1)*N + KD*NTHREADS + 2*N */ +/* > where KD is the size of the band. */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (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 doubleOTHEReigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsbevx_2stage_(char *jobz, char *range, char *uplo, + integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *q, + integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer * + iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, integer *lwork, integer *iwork, + integer *ifail, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, + i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer indd, inde; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + doublereal anrm; + integer imax; + doublereal rmin, rmax; + logical test; + extern /* Subroutine */ int dsytrd_sb2st_(char *, char *, char *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *); + integer itmp1, i__, j, indee; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer iinfo; + char order[1]; + integer lhtrd; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer lwmin; + logical lower; + integer lwtrd; + logical wantz; + integer ib, jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, indibl; + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + logical valeig; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal abstll, bignum; + integer indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo; + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *); + integer indwrk; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer nsplit, llwork; + doublereal smlnum; + logical lquery; + doublereal eps, vll, vuu; + integer indhous; + doublereal tmp1; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1; + + *info = 0; + if (! lsame_(jobz, "N")) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } else if (wantz && *ldq < f2cmax(1,*n)) { + *info = -9; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -11; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -12; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -13; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -18; + } + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + work[1] = (doublereal) lwmin; + } else { + ib = ilaenv2stage_(&c__2, "DSYTRD_SB2ST", jobz, n, kd, &c_n1, & + c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_SB2ST", jobz, n, kd, &ib, & + c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_SB2ST", jobz, n, kd, &ib, & + c_n1); + lwmin = (*n << 1) + lhtrd + lwtrd; + work[1] = (doublereal) lwmin; + } + + if (*lwork < lwmin && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEVX_2STAGE ", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + *m = 1; + if (lower) { + tmp1 = ab[ab_dim1 + 1]; + } else { + tmp1 = ab[*kd + 1 + ab_dim1]; + } + if (valeig) { + if (! (*vl < tmp1 && *vu >= tmp1)) { + *m = 0; + } + } + if (*m == 1) { + w[1] = tmp1; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + } + 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 = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + dlascl_("B", kd, kd, &c_b24, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b24, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. */ + + indd = 1; + inde = indd + *n; + indhous = inde + *n; + indwrk = indhous + lhtrd; + llwork = *lwork - indwrk + 1; + + dsytrd_sb2st_("N", jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], + &work[inde], &work[indhous], &lhtrd, &work[indwrk], &llwork, & + iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1); + dgemv_("N", n, n, &c_b24, &q[q_offset], ldq, &work[1], &c__1, & + c_b45, &z__[j * z_dim1 + 1], &c__1); +/* L20: */ + } + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L30: + 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]; + } +/* L40: */ + } + + 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; + dswap_(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; + } + } +/* L50: */ + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwmin; + + return 0; + +/* End of DSBEVX_2STAGE */ + +} /* dsbevx_2stage__ */ + diff --git a/lapack-netlib/SRC/dsbgst.c b/lapack-netlib/SRC/dsbgst.c new file mode 100644 index 000000000..a30f2d335 --- /dev/null +++ b/lapack-netlib/SRC/dsbgst.c @@ -0,0 +1,2208 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSBGST */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBGST + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, */ +/* LDX, WORK, INFO ) */ + +/* CHARACTER UPLO, VECT */ +/* INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N */ +/* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBGST reduces a real symmetric-definite banded generalized */ +/* > eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */ +/* > such that C has the same bandwidth as A. */ +/* > */ +/* > B must have been previously factorized as S**T*S by DPBSTF, using a */ +/* > split Cholesky factorization. A is overwritten by C = X**T*A*X, where */ +/* > X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the */ +/* > bandwidth of A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > = 'N': do not form the transformation matrix X; */ +/* > = 'V': form X. */ +/* > \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 matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KA */ +/* > \verbatim */ +/* > KA is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first ka+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for f2cmax(1,j-ka)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+ka). */ +/* > */ +/* > On exit, the transformed matrix X**T*A*X, stored in the same */ +/* > format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KA+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BB */ +/* > \verbatim */ +/* > BB is DOUBLE PRECISION array, dimension (LDBB,N) */ +/* > The banded factor S from the split Cholesky factorization of */ +/* > B, as returned by DPBSTF, stored in the first KB+1 rows of */ +/* > the array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBB */ +/* > \verbatim */ +/* > LDBB is INTEGER */ +/* > The leading dimension of the array BB. LDBB >= KB+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,N) */ +/* > If VECT = 'V', the n-by-n matrix X. */ +/* > If VECT = 'N', the array X is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. */ +/* > LDX >= f2cmax(1,N) if VECT = 'V'; LDX >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsbgst_(char *vect, char *uplo, integer *n, integer *ka, + integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer * + ldbb, doublereal *x, integer *ldx, doublereal *work, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, x_dim1, x_offset, i__1, + i__2, i__3, i__4; + doublereal d__1; + + /* Local variables */ + integer inca; + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *), drot_(integer *, doublereal *, integer *, doublereal * + , integer *, doublereal *, doublereal *); + integer i__, j, k, l, m; + doublereal t; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + integer i0, i1; + logical upper; + integer i2, j1, j2; + logical wantx; + extern /* Subroutine */ int dlar2v_(integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + doublereal ra; + integer nr, nx; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), xerbla_(char *, integer *, ftnlen), dlargv_( + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *); + logical update; + extern /* Subroutine */ int dlartv_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + integer ka1, kb1; + doublereal ra1; + integer j1t, j2t; + doublereal bii; + integer kbt, nrt; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1 * 1; + bb -= bb_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --work; + + /* Function Body */ + wantx = lsame_(vect, "V"); + upper = lsame_(uplo, "U"); + ka1 = *ka + 1; + kb1 = *kb + 1; + *info = 0; + if (! wantx && ! lsame_(vect, "N")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ka < 0) { + *info = -4; + } else if (*kb < 0 || *kb > *ka) { + *info = -5; + } else if (*ldab < *ka + 1) { + *info = -7; + } else if (*ldbb < *kb + 1) { + *info = -9; + } else if (*ldx < 1 || wantx && *ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGST", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + inca = *ldab * ka1; + +/* Initialize X to the unit matrix, if needed */ + + if (wantx) { + dlaset_("Full", n, n, &c_b8, &c_b9, &x[x_offset], ldx); + } + +/* Set M to the splitting point m. It must be the same value as is */ +/* used in DPBSTF. The chosen value allows the arrays WORK and RWORK */ +/* to be of dimension (N). */ + + m = (*n + *kb) / 2; + +/* The routine works in two phases, corresponding to the two halves */ +/* of the split Cholesky factorization of B as S**T*S where */ + +/* S = ( U ) */ +/* ( M L ) */ + +/* with U upper triangular of order m, and L lower triangular of */ +/* order n-m. S has the same bandwidth as B. */ + +/* S is treated as a product of elementary matrices: */ + +/* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) */ + +/* where S(i) is determined by the i-th row of S. */ + +/* In phase 1, the index i takes the values n, n-1, ... , m+1; */ +/* in phase 2, it takes the values 1, 2, ... , m. */ + +/* For each value of i, the current matrix A is updated by forming */ +/* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside */ +/* the band of A. The bulge is then pushed down toward the bottom of */ +/* A in phase 1, and up toward the top of A in phase 2, by applying */ +/* plane rotations. */ + +/* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 */ +/* of them are linearly independent, so annihilating a bulge requires */ +/* only 2*kb-1 plane rotations. The rotations are divided into a 1st */ +/* set of kb-1 rotations, and a 2nd set of kb rotations. */ + +/* Wherever possible, rotations are generated and applied in vector */ +/* operations of length NR between the indices J1 and J2 (sometimes */ +/* replaced by modified values NRT, J1T or J2T). */ + +/* The cosines and sines of the rotations are stored in the array */ +/* WORK. The cosines of the 1st set of rotations are stored in */ +/* elements n+2:n+m-kb-1 and the sines of the 1st set in elements */ +/* 2:m-kb-1; the cosines of the 2nd set are stored in elements */ +/* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. */ + +/* The bulges are not formed explicitly; nonzero elements outside the */ +/* band are created only when they are required for generating new */ +/* rotations; they are stored in the array WORK, in positions where */ +/* they are later overwritten by the sines of the rotations which */ +/* annihilate them. */ + +/* **************************** Phase 1 ***************************** */ + +/* The logical structure of this phase is: */ + +/* UPDATE = .TRUE. */ +/* DO I = N, M + 1, -1 */ +/* use S(i) to update A and create a new bulge */ +/* apply rotations to push all bulges KA positions downward */ +/* END DO */ +/* UPDATE = .FALSE. */ +/* DO I = M + KA + 1, N - 1 */ +/* apply rotations to push all bulges KA positions downward */ +/* END DO */ + +/* To avoid duplicating code, the two loops are merged. */ + + update = TRUE_; + i__ = *n + 1; +L10: + if (update) { + --i__; +/* Computing MIN */ + i__1 = *kb, i__2 = i__ - 1; + kbt = f2cmin(i__1,i__2); + i0 = i__ - 1; +/* Computing MIN */ + i__1 = *n, i__2 = i__ + *ka; + i1 = f2cmin(i__1,i__2); + i2 = i__ - kbt + ka1; + if (i__ < m + 1) { + update = FALSE_; + ++i__; + i0 = m; + if (*ka == 0) { + goto L480; + } + goto L10; + } + } else { + i__ += *ka; + if (i__ > *n - 1) { + goto L480; + } + } + + if (upper) { + +/* Transform A, working with the upper triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[kb1 + i__ * bb_dim1]; + i__1 = i1; + for (j = i__; j <= i__1; ++j) { + ab[i__ - j + ka1 + j * ab_dim1] /= bii; +/* L20: */ + } +/* Computing MAX */ + i__1 = 1, i__2 = i__ - *ka; + i__3 = i__; + for (j = f2cmax(i__1,i__2); j <= i__3; ++j) { + ab[j - i__ + ka1 + i__ * ab_dim1] /= bii; +/* L30: */ + } + i__3 = i__ - 1; + for (k = i__ - kbt; k <= i__3; ++k) { + i__1 = k; + for (j = i__ - kbt; j <= i__1; ++j) { + ab[j - k + ka1 + k * ab_dim1] = ab[j - k + ka1 + k * + ab_dim1] - bb[j - i__ + kb1 + i__ * bb_dim1] * ab[ + k - i__ + ka1 + i__ * ab_dim1] - bb[k - i__ + kb1 + + i__ * bb_dim1] * ab[j - i__ + ka1 + i__ * + ab_dim1] + ab[ka1 + i__ * ab_dim1] * bb[j - i__ + + kb1 + i__ * bb_dim1] * bb[k - i__ + kb1 + i__ * + bb_dim1]; +/* L40: */ + } +/* Computing MAX */ + i__1 = 1, i__2 = i__ - *ka; + i__4 = i__ - kbt - 1; + for (j = f2cmax(i__1,i__2); j <= i__4; ++j) { + ab[j - k + ka1 + k * ab_dim1] -= bb[k - i__ + kb1 + i__ * + bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1]; +/* L50: */ + } +/* L60: */ + } + i__3 = i1; + for (j = i__; j <= i__3; ++j) { +/* Computing MAX */ + i__4 = j - *ka, i__1 = i__ - kbt; + i__2 = i__ - 1; + for (k = f2cmax(i__4,i__1); k <= i__2; ++k) { + ab[k - j + ka1 + j * ab_dim1] -= bb[k - i__ + kb1 + i__ * + bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1]; +/* L70: */ + } +/* L80: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + i__3 = *n - m; + d__1 = 1. / bii; + dscal_(&i__3, &d__1, &x[m + 1 + i__ * x_dim1], &c__1); + if (kbt > 0) { + i__3 = *n - m; + dger_(&i__3, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], & + c__1, &bb[kb1 - kbt + i__ * bb_dim1], &c__1, &x[m + + 1 + (i__ - kbt) * x_dim1], ldx); + } + } + +/* store a(i,i1) in RA1 for use in next loop over K */ + + ra1 = ab[i__ - i1 + ka1 + i1 * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions down toward the bottom of the */ +/* band */ + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ - k + *ka < *n && i__ - k > 1) { + +/* generate rotation to annihilate a(i,i-k+ka+1) */ + + dlartg_(&ab[k + 1 + (i__ - k + *ka) * ab_dim1], &ra1, & + work[*n + i__ - k + *ka - m], &work[i__ - k + *ka + - m], &ra); + +/* create nonzero element a(i-k,i-k+ka+1) outside the */ +/* band and store it in WORK(i-k) */ + + t = -bb[kb1 - k + i__ * bb_dim1] * ra1; + work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[ + i__ - k + *ka - m] * ab[(i__ - k + *ka) * ab_dim1 + + 1]; + ab[(i__ - k + *ka) * ab_dim1 + 1] = work[i__ - k + *ka - + m] * t + work[*n + i__ - k + *ka - m] * ab[(i__ - + k + *ka) * ab_dim1 + 1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__2 = 1, i__4 = k - i0 + 2; + j2 = i__ - k - 1 + f2cmax(i__2,i__4) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (update) { +/* Computing MAX */ + i__2 = j2, i__4 = i__ + (*ka << 1) - k + 1; + j2t = f2cmax(i__2,i__4); + } else { + j2t = j2; + } + nrt = (*n - j2t + *ka) / ka1; + i__2 = j1; + i__4 = ka1; + for (j = j2t; i__4 < 0 ? j >= i__2 : j <= i__2; j += i__4) { + +/* create nonzero element a(j-ka,j+1) outside the band */ +/* and store it in WORK(j-m) */ + + work[j - m] *= ab[(j + 1) * ab_dim1 + 1]; + ab[(j + 1) * ab_dim1 + 1] = work[*n + j - m] * ab[(j + 1) * + ab_dim1 + 1]; +/* L90: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[j2t * ab_dim1 + 1], &inca, &work[j2t - m], & + ka1, &work[*n + j2t - m], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the right */ + + i__4 = *ka - 1; + for (l = 1; l <= i__4; ++l) { + dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka + - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2 - + m], &work[j2 - m], &ka1); +/* L100: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) * + ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[ + *n + j2 - m], &work[j2 - m], &ka1); + + } + +/* start applying rotations in 1st set from the left */ + + i__4 = *kb - k + 1; + for (l = *ka - 1; l >= i__4; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & + ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & + work[*n + j2 - m], &work[j2 - m], &ka1); + } +/* L110: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__4 = j1; + i__2 = ka1; + for (j = j2; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) { + i__1 = *n - m; + drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j + - m]); +/* L120: */ + } + } +/* L130: */ + } + + if (update) { + if (i2 <= *n && kbt > 0) { + +/* create nonzero element a(i-kbt,i-kbt+ka+1) outside the */ +/* band and store it in WORK(i-kbt) */ + + work[i__ - kbt] = -bb[kb1 - kbt + i__ * bb_dim1] * ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__3 = 2, i__2 = k - i0 + 1; + j2 = i__ - k - 1 + f2cmax(i__3,i__2) * ka1; + } else { +/* Computing MAX */ + i__3 = 1, i__2 = k - i0 + 1; + j2 = i__ - k - 1 + f2cmax(i__3,i__2) * ka1; + } + +/* finish applying rotations in 2nd set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + *ka + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 - l + 1) * ab_dim1], &inca, &ab[ + l + 1 + (j2 - l + 1) * ab_dim1], &inca, &work[*n + + j2 - *ka], &work[j2 - *ka], &ka1); + } +/* L140: */ + } + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + i__3 = j2; + i__2 = -ka1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) { + work[j] = work[j - *ka]; + work[*n + j] = work[*n + j - *ka]; +/* L150: */ + } + i__2 = j1; + i__3 = ka1; + for (j = j2; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) { + +/* create nonzero element a(j-ka,j+1) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[(j + 1) * ab_dim1 + 1]; + ab[(j + 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + 1) * + ab_dim1 + 1]; +/* L160: */ + } + if (update) { + if (i__ - k < *n - *ka && k <= kbt) { + work[i__ - k + *ka] = work[i__ - k]; + } + } +/* L170: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__3 = 1, i__2 = k - i0 + 1; + j2 = i__ - k - 1 + f2cmax(i__3,i__2) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[j2 * ab_dim1 + 1], &inca, &work[j2], &ka1, & + work[*n + j2], &ka1); + +/* apply rotations in 2nd set from the right */ + + i__3 = *ka - 1; + for (l = 1; l <= i__3; ++l) { + dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka + - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2], + &work[j2], &ka1); +/* L180: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) * + ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[ + *n + j2], &work[j2], &ka1); + + } + +/* start applying rotations in 2nd set from the left */ + + i__3 = *kb - k + 1; + for (l = *ka - 1; l >= i__3; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & + ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & + work[*n + j2], &work[j2], &ka1); + } +/* L190: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__3 = j1; + i__2 = ka1; + for (j = j2; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) { + i__4 = *n - m; + drot_(&i__4, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j], &work[j]); +/* L200: */ + } + } +/* L210: */ + } + + i__2 = *kb - 1; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + i__3 = 1, i__4 = k - i0 + 2; + j2 = i__ - k - 1 + f2cmax(i__3,i__4) * ka1; + +/* finish applying rotations in 1st set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & + ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & + work[*n + j2 - m], &work[j2 - m], &ka1); + } +/* L220: */ + } +/* L230: */ + } + + if (*kb > 1) { + i__2 = i__ - *kb + (*ka << 1) + 1; + for (j = *n - 1; j >= i__2; --j) { + work[*n + j - m] = work[*n + j - *ka - m]; + work[j - m] = work[j - *ka - m]; +/* L240: */ + } + } + + } else { + +/* Transform A, working with the lower triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[i__ * bb_dim1 + 1]; + i__2 = i1; + for (j = i__; j <= i__2; ++j) { + ab[j - i__ + 1 + i__ * ab_dim1] /= bii; +/* L250: */ + } +/* Computing MAX */ + i__2 = 1, i__3 = i__ - *ka; + i__4 = i__; + for (j = f2cmax(i__2,i__3); j <= i__4; ++j) { + ab[i__ - j + 1 + j * ab_dim1] /= bii; +/* L260: */ + } + i__4 = i__ - 1; + for (k = i__ - kbt; k <= i__4; ++k) { + i__2 = k; + for (j = i__ - kbt; j <= i__2; ++j) { + ab[k - j + 1 + j * ab_dim1] = ab[k - j + 1 + j * ab_dim1] + - bb[i__ - j + 1 + j * bb_dim1] * ab[i__ - k + 1 + + k * ab_dim1] - bb[i__ - k + 1 + k * bb_dim1] * + ab[i__ - j + 1 + j * ab_dim1] + ab[i__ * ab_dim1 + + 1] * bb[i__ - j + 1 + j * bb_dim1] * bb[i__ - k + + 1 + k * bb_dim1]; +/* L270: */ + } +/* Computing MAX */ + i__2 = 1, i__3 = i__ - *ka; + i__1 = i__ - kbt - 1; + for (j = f2cmax(i__2,i__3); j <= i__1; ++j) { + ab[k - j + 1 + j * ab_dim1] -= bb[i__ - k + 1 + k * + bb_dim1] * ab[i__ - j + 1 + j * ab_dim1]; +/* L280: */ + } +/* L290: */ + } + i__4 = i1; + for (j = i__; j <= i__4; ++j) { +/* Computing MAX */ + i__1 = j - *ka, i__2 = i__ - kbt; + i__3 = i__ - 1; + for (k = f2cmax(i__1,i__2); k <= i__3; ++k) { + ab[j - k + 1 + k * ab_dim1] -= bb[i__ - k + 1 + k * + bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1]; +/* L300: */ + } +/* L310: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + i__4 = *n - m; + d__1 = 1. / bii; + dscal_(&i__4, &d__1, &x[m + 1 + i__ * x_dim1], &c__1); + if (kbt > 0) { + i__4 = *n - m; + i__3 = *ldbb - 1; + dger_(&i__4, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], & + c__1, &bb[kbt + 1 + (i__ - kbt) * bb_dim1], &i__3, + &x[m + 1 + (i__ - kbt) * x_dim1], ldx); + } + } + +/* store a(i1,i) in RA1 for use in next loop over K */ + + ra1 = ab[i1 - i__ + 1 + i__ * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions down toward the bottom of the */ +/* band */ + + i__4 = *kb - 1; + for (k = 1; k <= i__4; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ - k + *ka < *n && i__ - k > 1) { + +/* generate rotation to annihilate a(i-k+ka+1,i) */ + + dlartg_(&ab[ka1 - k + i__ * ab_dim1], &ra1, &work[*n + + i__ - k + *ka - m], &work[i__ - k + *ka - m], &ra) + ; + +/* create nonzero element a(i-k+ka+1,i-k) outside the */ +/* band and store it in WORK(i-k) */ + + t = -bb[k + 1 + (i__ - k) * bb_dim1] * ra1; + work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[ + i__ - k + *ka - m] * ab[ka1 + (i__ - k) * ab_dim1] + ; + ab[ka1 + (i__ - k) * ab_dim1] = work[i__ - k + *ka - m] * + t + work[*n + i__ - k + *ka - m] * ab[ka1 + (i__ + - k) * ab_dim1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__3 = 1, i__1 = k - i0 + 2; + j2 = i__ - k - 1 + f2cmax(i__3,i__1) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (update) { +/* Computing MAX */ + i__3 = j2, i__1 = i__ + (*ka << 1) - k + 1; + j2t = f2cmax(i__3,i__1); + } else { + j2t = j2; + } + nrt = (*n - j2t + *ka) / ka1; + i__3 = j1; + i__1 = ka1; + for (j = j2t; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) { + +/* create nonzero element a(j+1,j-ka) outside the band */ +/* and store it in WORK(j-m) */ + + work[j - m] *= ab[ka1 + (j - *ka + 1) * ab_dim1]; + ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j - m] * ab[ka1 + + (j - *ka + 1) * ab_dim1]; +/* L320: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[ka1 + (j2t - *ka) * ab_dim1], &inca, &work[ + j2t - m], &ka1, &work[*n + j2t - m], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the left */ + + i__1 = *ka - 1; + for (l = 1; l <= i__1; ++l) { + dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[ + l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2 + - m], &work[j2 - m], &ka1); +/* L330: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 + + 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2 - m], + &work[j2 - m], &ka1); + + } + +/* start applying rotations in 1st set from the right */ + + i__1 = *kb - k + 1; + for (l = *ka - 1; l >= i__1; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ + ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + + j2 - m], &work[j2 - m], &ka1); + } +/* L340: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__1 = j1; + i__3 = ka1; + for (j = j2; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { + i__2 = *n - m; + drot_(&i__2, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j + - m]); +/* L350: */ + } + } +/* L360: */ + } + + if (update) { + if (i2 <= *n && kbt > 0) { + +/* create nonzero element a(i-kbt+ka+1,i-kbt) outside the */ +/* band and store it in WORK(i-kbt) */ + + work[i__ - kbt] = -bb[kbt + 1 + (i__ - kbt) * bb_dim1] * ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__4 = 2, i__3 = k - i0 + 1; + j2 = i__ - k - 1 + f2cmax(i__4,i__3) * ka1; + } else { +/* Computing MAX */ + i__4 = 1, i__3 = k - i0 + 1; + j2 = i__ - k - 1 + f2cmax(i__4,i__3) * ka1; + } + +/* finish applying rotations in 2nd set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + *ka + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j2 - *ka) * ab_dim1], & + inca, &ab[ka1 - l + (j2 - *ka + 1) * ab_dim1], & + inca, &work[*n + j2 - *ka], &work[j2 - *ka], &ka1) + ; + } +/* L370: */ + } + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + i__4 = j2; + i__3 = -ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + work[j] = work[j - *ka]; + work[*n + j] = work[*n + j - *ka]; +/* L380: */ + } + i__3 = j1; + i__4 = ka1; + for (j = j2; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j+1,j-ka) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[ka1 + (j - *ka + 1) * ab_dim1]; + ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j] * ab[ka1 + ( + j - *ka + 1) * ab_dim1]; +/* L390: */ + } + if (update) { + if (i__ - k < *n - *ka && k <= kbt) { + work[i__ - k + *ka] = work[i__ - k]; + } + } +/* L400: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__4 = 1, i__3 = k - i0 + 1; + j2 = i__ - k - 1 + f2cmax(i__4,i__3) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[ka1 + (j2 - *ka) * ab_dim1], &inca, &work[j2] + , &ka1, &work[*n + j2], &ka1); + +/* apply rotations in 2nd set from the left */ + + i__4 = *ka - 1; + for (l = 1; l <= i__4; ++l) { + dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[ + l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2] + , &work[j2], &ka1); +/* L410: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 + + 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2], & + work[j2], &ka1); + + } + +/* start applying rotations in 2nd set from the right */ + + i__4 = *kb - k + 1; + for (l = *ka - 1; l >= i__4; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ + ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + + j2], &work[j2], &ka1); + } +/* L420: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__4 = j1; + i__3 = ka1; + for (j = j2; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + i__1 = *n - m; + drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j], &work[j]); +/* L430: */ + } + } +/* L440: */ + } + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { +/* Computing MAX */ + i__4 = 1, i__1 = k - i0 + 2; + j2 = i__ - k - 1 + f2cmax(i__4,i__1) * ka1; + +/* finish applying rotations in 1st set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ + ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + + j2 - m], &work[j2 - m], &ka1); + } +/* L450: */ + } +/* L460: */ + } + + if (*kb > 1) { + i__3 = i__ - *kb + (*ka << 1) + 1; + for (j = *n - 1; j >= i__3; --j) { + work[*n + j - m] = work[*n + j - *ka - m]; + work[j - m] = work[j - *ka - m]; +/* L470: */ + } + } + + } + + goto L10; + +L480: + +/* **************************** Phase 2 ***************************** */ + +/* The logical structure of this phase is: */ + +/* UPDATE = .TRUE. */ +/* DO I = 1, M */ +/* use S(i) to update A and create a new bulge */ +/* apply rotations to push all bulges KA positions upward */ +/* END DO */ +/* UPDATE = .FALSE. */ +/* DO I = M - KA - 1, 2, -1 */ +/* apply rotations to push all bulges KA positions upward */ +/* END DO */ + +/* To avoid duplicating code, the two loops are merged. */ + + update = TRUE_; + i__ = 0; +L490: + if (update) { + ++i__; +/* Computing MIN */ + i__3 = *kb, i__4 = m - i__; + kbt = f2cmin(i__3,i__4); + i0 = i__ + 1; +/* Computing MAX */ + i__3 = 1, i__4 = i__ - *ka; + i1 = f2cmax(i__3,i__4); + i2 = i__ + kbt - ka1; + if (i__ > m) { + update = FALSE_; + --i__; + i0 = m + 1; + if (*ka == 0) { + return 0; + } + goto L490; + } + } else { + i__ -= *ka; + if (i__ < 2) { + return 0; + } + } + + if (i__ < m - kbt) { + nx = m; + } else { + nx = *n; + } + + if (upper) { + +/* Transform A, working with the upper triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[kb1 + i__ * bb_dim1]; + i__3 = i__; + for (j = i1; j <= i__3; ++j) { + ab[j - i__ + ka1 + i__ * ab_dim1] /= bii; +/* L500: */ + } +/* Computing MIN */ + i__4 = *n, i__1 = i__ + *ka; + i__3 = f2cmin(i__4,i__1); + for (j = i__; j <= i__3; ++j) { + ab[i__ - j + ka1 + j * ab_dim1] /= bii; +/* L510: */ + } + i__3 = i__ + kbt; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = i__ + kbt; + for (j = k; j <= i__4; ++j) { + ab[k - j + ka1 + j * ab_dim1] = ab[k - j + ka1 + j * + ab_dim1] - bb[i__ - j + kb1 + j * bb_dim1] * ab[ + i__ - k + ka1 + k * ab_dim1] - bb[i__ - k + kb1 + + k * bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1] + + ab[ka1 + i__ * ab_dim1] * bb[i__ - j + kb1 + j * + bb_dim1] * bb[i__ - k + kb1 + k * bb_dim1]; +/* L520: */ + } +/* Computing MIN */ + i__1 = *n, i__2 = i__ + *ka; + i__4 = f2cmin(i__1,i__2); + for (j = i__ + kbt + 1; j <= i__4; ++j) { + ab[k - j + ka1 + j * ab_dim1] -= bb[i__ - k + kb1 + k * + bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1]; +/* L530: */ + } +/* L540: */ + } + i__3 = i__; + for (j = i1; j <= i__3; ++j) { +/* Computing MIN */ + i__1 = j + *ka, i__2 = i__ + kbt; + i__4 = f2cmin(i__1,i__2); + for (k = i__ + 1; k <= i__4; ++k) { + ab[j - k + ka1 + k * ab_dim1] -= bb[i__ - k + kb1 + k * + bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1]; +/* L550: */ + } +/* L560: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + d__1 = 1. / bii; + dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1); + if (kbt > 0) { + i__3 = *ldbb - 1; + dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[ + *kb + (i__ + 1) * bb_dim1], &i__3, &x[(i__ + 1) * + x_dim1 + 1], ldx); + } + } + +/* store a(i1,i) in RA1 for use in next loop over K */ + + ra1 = ab[i1 - i__ + ka1 + i__ * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions up toward the top of the band */ + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ + k - ka1 > 0 && i__ + k < m) { + +/* generate rotation to annihilate a(i+k-ka-1,i) */ + + dlartg_(&ab[k + 1 + i__ * ab_dim1], &ra1, &work[*n + i__ + + k - *ka], &work[i__ + k - *ka], &ra); + +/* create nonzero element a(i+k-ka-1,i+k) outside the */ +/* band and store it in WORK(m-kb+i+k) */ + + t = -bb[kb1 - k + (i__ + k) * bb_dim1] * ra1; + work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t - + work[i__ + k - *ka] * ab[(i__ + k) * ab_dim1 + 1]; + ab[(i__ + k) * ab_dim1 + 1] = work[i__ + k - *ka] * t + + work[*n + i__ + k - *ka] * ab[(i__ + k) * ab_dim1 + + 1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__4 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - f2cmax(i__4,i__1) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (update) { +/* Computing MIN */ + i__4 = j2, i__1 = i__ - (*ka << 1) + k - 1; + j2t = f2cmin(i__4,i__1); + } else { + j2t = j2; + } + nrt = (j2t + *ka - 1) / ka1; + i__4 = j2t; + i__1 = ka1; + for (j = j1; i__1 < 0 ? j >= i__4 : j <= i__4; j += i__1) { + +/* create nonzero element a(j-1,j+ka) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[(j + *ka - 1) * ab_dim1 + 1]; + ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + *ka + - 1) * ab_dim1 + 1]; +/* L570: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[j1], + &ka1, &work[*n + j1], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the left */ + + i__1 = *ka - 1; + for (l = 1; l <= i__1; ++l) { + dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, & + ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n + + j1], &work[j1], &ka1); +/* L580: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) * + ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n + + j1], &work[j1], &ka1); + + } + +/* start applying rotations in 1st set from the right */ + + i__1 = *kb - k + 1; + for (l = *ka - 1; l >= i__1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( + j1t - 1) * ab_dim1], &inca, &work[*n + j1t], & + work[j1t], &ka1); + } +/* L590: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__1 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__1 : j <= i__1; j += i__4) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + j], &work[j]); +/* L600: */ + } + } +/* L610: */ + } + + if (update) { + if (i2 > 0 && kbt > 0) { + +/* create nonzero element a(i+kbt-ka-1,i+kbt) outside the */ +/* band and store it in WORK(m-kb+i+kbt) */ + + work[m - *kb + i__ + kbt] = -bb[kb1 - kbt + (i__ + kbt) * + bb_dim1] * ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__3 = 2, i__4 = k + i0 - m; + j2 = i__ + k + 1 - f2cmax(i__3,i__4) * ka1; + } else { +/* Computing MAX */ + i__3 = 1, i__4 = k + i0 - m; + j2 = i__ + k + 1 - f2cmax(i__3,i__4) * ka1; + } + +/* finish applying rotations in 2nd set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + *ka + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j1t + *ka) * ab_dim1], &inca, &ab[ + l + 1 + (j1t + *ka - 1) * ab_dim1], &inca, &work[* + n + m - *kb + j1t + *ka], &work[m - *kb + j1t + * + ka], &ka1); + } +/* L620: */ + } + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + i__3 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + work[m - *kb + j] = work[m - *kb + j + *ka]; + work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka]; +/* L630: */ + } + i__4 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + +/* create nonzero element a(j-1,j+ka) outside the band */ +/* and store it in WORK(m-kb+j) */ + + work[m - *kb + j] *= ab[(j + *ka - 1) * ab_dim1 + 1]; + ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + m - *kb + j] * ab[ + (j + *ka - 1) * ab_dim1 + 1]; +/* L640: */ + } + if (update) { + if (i__ + k > ka1 && k <= kbt) { + work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k]; + } + } +/* L650: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__3 = 1, i__4 = k + i0 - m; + j2 = i__ + k + 1 - f2cmax(i__3,i__4) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[m - * + kb + j1], &ka1, &work[*n + m - *kb + j1], &ka1); + +/* apply rotations in 2nd set from the left */ + + i__3 = *ka - 1; + for (l = 1; l <= i__3; ++l) { + dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, & + ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n + + m - *kb + j1], &work[m - *kb + j1], &ka1); +/* L660: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) * + ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n + + m - *kb + j1], &work[m - *kb + j1], &ka1); + + } + +/* start applying rotations in 2nd set from the right */ + + i__3 = *kb - k + 1; + for (l = *ka - 1; l >= i__3; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( + j1t - 1) * ab_dim1], &inca, &work[*n + m - *kb + + j1t], &work[m - *kb + j1t], &ka1); + } +/* L670: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__3 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + m - *kb + j], &work[m - * + kb + j]); +/* L680: */ + } + } +/* L690: */ + } + + i__4 = *kb - 1; + for (k = 1; k <= i__4; ++k) { +/* Computing MAX */ + i__3 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - f2cmax(i__3,i__1) * ka1; + +/* finish applying rotations in 1st set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( + j1t - 1) * ab_dim1], &inca, &work[*n + j1t], & + work[j1t], &ka1); + } +/* L700: */ + } +/* L710: */ + } + + if (*kb > 1) { +/* Computing MIN */ + i__3 = i__ + *kb; + i__4 = f2cmin(i__3,m) - (*ka << 1) - 1; + for (j = 2; j <= i__4; ++j) { + work[*n + j] = work[*n + j + *ka]; + work[j] = work[j + *ka]; +/* L720: */ + } + } + + } else { + +/* Transform A, working with the lower triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[i__ * bb_dim1 + 1]; + i__4 = i__; + for (j = i1; j <= i__4; ++j) { + ab[i__ - j + 1 + j * ab_dim1] /= bii; +/* L730: */ + } +/* Computing MIN */ + i__3 = *n, i__1 = i__ + *ka; + i__4 = f2cmin(i__3,i__1); + for (j = i__; j <= i__4; ++j) { + ab[j - i__ + 1 + i__ * ab_dim1] /= bii; +/* L740: */ + } + i__4 = i__ + kbt; + for (k = i__ + 1; k <= i__4; ++k) { + i__3 = i__ + kbt; + for (j = k; j <= i__3; ++j) { + ab[j - k + 1 + k * ab_dim1] = ab[j - k + 1 + k * ab_dim1] + - bb[j - i__ + 1 + i__ * bb_dim1] * ab[k - i__ + + 1 + i__ * ab_dim1] - bb[k - i__ + 1 + i__ * + bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1] + ab[ + i__ * ab_dim1 + 1] * bb[j - i__ + 1 + i__ * + bb_dim1] * bb[k - i__ + 1 + i__ * bb_dim1]; +/* L750: */ + } +/* Computing MIN */ + i__1 = *n, i__2 = i__ + *ka; + i__3 = f2cmin(i__1,i__2); + for (j = i__ + kbt + 1; j <= i__3; ++j) { + ab[j - k + 1 + k * ab_dim1] -= bb[k - i__ + 1 + i__ * + bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1]; +/* L760: */ + } +/* L770: */ + } + i__4 = i__; + for (j = i1; j <= i__4; ++j) { +/* Computing MIN */ + i__1 = j + *ka, i__2 = i__ + kbt; + i__3 = f2cmin(i__1,i__2); + for (k = i__ + 1; k <= i__3; ++k) { + ab[k - j + 1 + j * ab_dim1] -= bb[k - i__ + 1 + i__ * + bb_dim1] * ab[i__ - j + 1 + j * ab_dim1]; +/* L780: */ + } +/* L790: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + d__1 = 1. / bii; + dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1); + if (kbt > 0) { + dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[ + i__ * bb_dim1 + 2], &c__1, &x[(i__ + 1) * x_dim1 + + 1], ldx); + } + } + +/* store a(i,i1) in RA1 for use in next loop over K */ + + ra1 = ab[i__ - i1 + 1 + i1 * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions up toward the top of the band */ + + i__4 = *kb - 1; + for (k = 1; k <= i__4; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ + k - ka1 > 0 && i__ + k < m) { + +/* generate rotation to annihilate a(i,i+k-ka-1) */ + + dlartg_(&ab[ka1 - k + (i__ + k - *ka) * ab_dim1], &ra1, & + work[*n + i__ + k - *ka], &work[i__ + k - *ka], & + ra); + +/* create nonzero element a(i+k,i+k-ka-1) outside the */ +/* band and store it in WORK(m-kb+i+k) */ + + t = -bb[k + 1 + i__ * bb_dim1] * ra1; + work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t - + work[i__ + k - *ka] * ab[ka1 + (i__ + k - *ka) * + ab_dim1]; + ab[ka1 + (i__ + k - *ka) * ab_dim1] = work[i__ + k - *ka] + * t + work[*n + i__ + k - *ka] * ab[ka1 + (i__ + + k - *ka) * ab_dim1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__3 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - f2cmax(i__3,i__1) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (update) { +/* Computing MIN */ + i__3 = j2, i__1 = i__ - (*ka << 1) + k - 1; + j2t = f2cmin(i__3,i__1); + } else { + j2t = j2; + } + nrt = (j2t + *ka - 1) / ka1; + i__3 = j2t; + i__1 = ka1; + for (j = j1; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) { + +/* create nonzero element a(j+ka,j-1) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[ka1 + (j - 1) * ab_dim1]; + ab[ka1 + (j - 1) * ab_dim1] = work[*n + j] * ab[ka1 + (j - 1) + * ab_dim1]; +/* L800: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[ka1 + j1 * ab_dim1], &inca, &work[j1], &ka1, + &work[*n + j1], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the right */ + + i__1 = *ka - 1; + for (l = 1; l <= i__1; ++l) { + dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2 + + (j1 - 1) * ab_dim1], &inca, &work[*n + j1], & + work[j1], &ka1); +/* L810: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + + 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + j1] + , &work[j1], &ka1); + + } + +/* start applying rotations in 1st set from the left */ + + i__1 = *kb - k + 1; + for (l = *ka - 1; l >= i__1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] + , &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], + &inca, &work[*n + j1t], &work[j1t], &ka1); + } +/* L820: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__1 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + j], &work[j]); +/* L830: */ + } + } +/* L840: */ + } + + if (update) { + if (i2 > 0 && kbt > 0) { + +/* create nonzero element a(i+kbt,i+kbt-ka-1) outside the */ +/* band and store it in WORK(m-kb+i+kbt) */ + + work[m - *kb + i__ + kbt] = -bb[kbt + 1 + i__ * bb_dim1] * + ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__4 = 2, i__3 = k + i0 - m; + j2 = i__ + k + 1 - f2cmax(i__4,i__3) * ka1; + } else { +/* Computing MAX */ + i__4 = 1, i__3 = k + i0 - m; + j2 = i__ + k + 1 - f2cmax(i__4,i__3) * ka1; + } + +/* finish applying rotations in 2nd set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + *ka + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t + l - 1) * ab_dim1], + &inca, &ab[ka1 - l + (j1t + l - 1) * ab_dim1], & + inca, &work[*n + m - *kb + j1t + *ka], &work[m - * + kb + j1t + *ka], &ka1); + } +/* L850: */ + } + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + i__4 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + work[m - *kb + j] = work[m - *kb + j + *ka]; + work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka]; +/* L860: */ + } + i__3 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j+ka,j-1) outside the band */ +/* and store it in WORK(m-kb+j) */ + + work[m - *kb + j] *= ab[ka1 + (j - 1) * ab_dim1]; + ab[ka1 + (j - 1) * ab_dim1] = work[*n + m - *kb + j] * ab[ka1 + + (j - 1) * ab_dim1]; +/* L870: */ + } + if (update) { + if (i__ + k > ka1 && k <= kbt) { + work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k]; + } + } +/* L880: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__4 = 1, i__3 = k + i0 - m; + j2 = i__ + k + 1 - f2cmax(i__4,i__3) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[ka1 + j1 * ab_dim1], &inca, &work[m - *kb + + j1], &ka1, &work[*n + m - *kb + j1], &ka1); + +/* apply rotations in 2nd set from the right */ + + i__4 = *ka - 1; + for (l = 1; l <= i__4; ++l) { + dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2 + + (j1 - 1) * ab_dim1], &inca, &work[*n + m - *kb + + j1], &work[m - *kb + j1], &ka1); +/* L890: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + + 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + m + - *kb + j1], &work[m - *kb + j1], &ka1); + + } + +/* start applying rotations in 2nd set from the left */ + + i__4 = *kb - k + 1; + for (l = *ka - 1; l >= i__4; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] + , &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], + &inca, &work[*n + m - *kb + j1t], &work[m - *kb + + j1t], &ka1); + } +/* L900: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__4 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + m - *kb + j], &work[m - * + kb + j]); +/* L910: */ + } + } +/* L920: */ + } + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { +/* Computing MAX */ + i__4 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - f2cmax(i__4,i__1) * ka1; + +/* finish applying rotations in 1st set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] + , &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], + &inca, &work[*n + j1t], &work[j1t], &ka1); + } +/* L930: */ + } +/* L940: */ + } + + if (*kb > 1) { +/* Computing MIN */ + i__4 = i__ + *kb; + i__3 = f2cmin(i__4,m) - (*ka << 1) - 1; + for (j = 2; j <= i__3; ++j) { + work[*n + j] = work[*n + j + *ka]; + work[j] = work[j + *ka]; +/* L950: */ + } + } + + } + + goto L490; + +/* End of DSBGST */ + +} /* dsbgst_ */ + diff --git a/lapack-netlib/SRC/dsbgv.c b/lapack-netlib/SRC/dsbgv.c new file mode 100644 index 000000000..8c06d5783 --- /dev/null +++ b/lapack-netlib/SRC/dsbgv.c @@ -0,0 +1,688 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSBGV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, */ +/* LDZ, WORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N */ +/* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBGV computes all the eigenvalues, and optionally, the eigenvectors */ +/* > of a real generalized symmetric-definite banded eigenproblem, of */ +/* > the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */ +/* > and banded, and B is also positive definite. */ +/* > \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 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] KA */ +/* > \verbatim */ +/* > KA is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first ka+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for f2cmax(1,j-ka)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+ka). */ +/* > */ +/* > On exit, the contents of AB are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KA+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BB */ +/* > \verbatim */ +/* > BB is DOUBLE PRECISION array, dimension (LDBB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix B, stored in the first kb+1 rows of the array. The */ +/* > j-th column of B is stored in the j-th column of the array BB */ +/* > as follows: */ +/* > if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for f2cmax(1,j-kb)<=i<=j; */ +/* > if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=f2cmin(n,j+kb). */ +/* > */ +/* > On exit, the factor S from the split Cholesky factorization */ +/* > B = S**T*S, as returned by DPBSTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBB */ +/* > \verbatim */ +/* > LDBB is INTEGER */ +/* > The leading dimension of the array BB. LDBB >= KB+1. */ +/* > \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 DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* > eigenvectors, with the i-th column of Z holding the */ +/* > eigenvector associated with W(i). The eigenvectors are */ +/* > normalized so that Z**T*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 >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: the algorithm failed to converge: */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to zero; */ +/* > > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */ +/* > returned INFO = i: 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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dsbgv_(char *jobz, char *uplo, integer *n, integer *ka, + integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer * + ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; + + /* Local variables */ + integer inde; + char vect[1]; + extern logical lsame_(char *, char *); + integer iinfo; + logical upper, wantz; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpbstf_( + char *, integer *, integer *, doublereal *, integer *, integer *), dsbtrd_(char *, char *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dsbgst_(char *, char *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *), dsterf_(integer *, doublereal *, + doublereal *, integer *); + integer indwrk; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1 * 1; + bb -= bb_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ka < 0) { + *info = -4; + } else if (*kb < 0 || *kb > *ka) { + *info = -5; + } else if (*ldab < *ka + 1) { + *info = -7; + } else if (*ldbb < *kb + 1) { + *info = -9; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGV ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a split Cholesky factorization of B. */ + + dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem. */ + + inde = 1; + indwrk = inde + *n; + dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, + &z__[z_offset], ldz, &work[indwrk], &iinfo) + ; + +/* Reduce to tridiagonal form. */ + + if (wantz) { + *(unsigned char *)vect = 'U'; + } else { + *(unsigned char *)vect = 'N'; + } + dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ + indwrk], info); + } + return 0; + +/* End of DSBGV */ + +} /* dsbgv_ */ + diff --git a/lapack-netlib/SRC/dsbgvd.c b/lapack-netlib/SRC/dsbgvd.c new file mode 100644 index 000000000..d5bb5f439 --- /dev/null +++ b/lapack-netlib/SRC/dsbgvd.c @@ -0,0 +1,787 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSBGVD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBGVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, */ +/* Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBGVD computes all the eigenvalues, and optionally, the eigenvectors */ +/* > of a real generalized symmetric-definite banded eigenproblem, of the */ +/* > form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and */ +/* > banded, 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] 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] KA */ +/* > \verbatim */ +/* > KA is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first ka+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for f2cmax(1,j-ka)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+ka). */ +/* > */ +/* > On exit, the contents of AB are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KA+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BB */ +/* > \verbatim */ +/* > BB is DOUBLE PRECISION array, dimension (LDBB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix B, stored in the first kb+1 rows of the array. The */ +/* > j-th column of B is stored in the j-th column of the array BB */ +/* > as follows: */ +/* > if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for f2cmax(1,j-kb)<=i<=j; */ +/* > if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=f2cmin(n,j+kb). */ +/* > */ +/* > On exit, the factor S from the split Cholesky factorization */ +/* > B = S**T*S, as returned by DPBSTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBB */ +/* > \verbatim */ +/* > LDBB is INTEGER */ +/* > The leading dimension of the array BB. LDBB >= KB+1. */ +/* > \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 DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* > eigenvectors, with the i-th column of Z holding the */ +/* > eigenvector associated with W(i). The eigenvectors are */ +/* > normalized so Z**T*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 DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N <= 1, LWORK >= 1. */ +/* > If JOBZ = 'N' and N > 1, LWORK >= 2*N. */ +/* > If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK or */ +/* > LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the 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 optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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, and i is: */ +/* > <= N: the algorithm failed to converge: */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to zero; */ +/* > > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */ +/* > returned INFO = i: 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 doubleOTHEReigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dsbgvd_(char *jobz, char *uplo, integer *n, integer *ka, + integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer * + ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; + + /* Local variables */ + integer inde; + char vect[1]; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + integer iinfo, lwmin; + logical upper, wantz; + integer indwk2, llwrk2; + extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *, integer *, integer *), dlacpy_(char *, integer + *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen), dpbstf_(char *, + integer *, integer *, doublereal *, integer *, integer *), + dsbtrd_(char *, char *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dsbgst_(char *, char *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *), dsterf_(integer *, doublereal *, + doublereal *, integer *); + integer indwrk, liwmin; + logical lquery; + + +/* -- 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1 * 1; + bb -= bb_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = *n << 1; + } + + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ka < 0) { + *info = -4; + } else if (*kb < 0 || *kb > *ka) { + *info = -5; + } else if (*ldab < *ka + 1) { + *info = -7; + } else if (*ldbb < *kb + 1) { + *info = -9; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -12; + } + + if (*info == 0) { + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -14; + } else if (*liwork < liwmin && ! lquery) { + *info = -16; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGVD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a split Cholesky factorization of B. */ + + dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem. */ + + inde = 1; + indwrk = inde + *n; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, + &z__[z_offset], ldz, &work[1], &iinfo); + +/* Reduce to tridiagonal form. */ + + if (wantz) { + *(unsigned char *)vect = 'U'; + } else { + *(unsigned char *)vect = 'N'; + } + dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dgemm_("N", "N", n, n, n, &c_b12, &z__[z_offset], ldz, &work[indwrk], + n, &c_b13, &work[indwk2], n); + dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSBGVD */ + +} /* dsbgvd_ */ + diff --git a/lapack-netlib/SRC/dsbgvx.c b/lapack-netlib/SRC/dsbgvx.c new file mode 100644 index 000000000..dc060d20a --- /dev/null +++ b/lapack-netlib/SRC/dsbgvx.c @@ -0,0 +1,966 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSBGVX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBGVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, */ +/* LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, */ +/* LDZ, WORK, IWORK, IFAIL, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, */ +/* $ N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), */ +/* $ W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBGVX computes selected eigenvalues, and optionally, eigenvectors */ +/* > of a real generalized symmetric-definite banded eigenproblem, of */ +/* > the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */ +/* > and banded, and B is also positive definite. Eigenvalues and */ +/* > eigenvectors can be selected by specifying either all eigenvalues, */ +/* > 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 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] KA */ +/* > \verbatim */ +/* > KA is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first ka+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for f2cmax(1,j-ka)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+ka). */ +/* > */ +/* > On exit, the contents of AB are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KA+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BB */ +/* > \verbatim */ +/* > BB is DOUBLE PRECISION array, dimension (LDBB, N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix B, stored in the first kb+1 rows of the array. The */ +/* > j-th column of B is stored in the j-th column of the array BB */ +/* > as follows: */ +/* > if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for f2cmax(1,j-kb)<=i<=j; */ +/* > if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=f2cmin(n,j+kb). */ +/* > */ +/* > On exit, the factor S from the split Cholesky factorization */ +/* > B = S**T*S, as returned by DPBSTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBB */ +/* > \verbatim */ +/* > LDBB is INTEGER */ +/* > The leading dimension of the array BB. LDBB >= KB+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */ +/* > If JOBZ = 'V', the n-by-n matrix used in the reduction of */ +/* > A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */ +/* > and consequently C to tridiagonal form. */ +/* > If JOBZ = 'N', the array Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. If JOBZ = 'N', */ +/* > LDQ >= 1. If JOBZ = 'V', LDQ >= f2cmax(1,N). */ +/* > \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 A 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) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* > eigenvectors, with the i-th column of Z holding the */ +/* > eigenvector associated with W(i). The eigenvectors are */ +/* > normalized so Z**T*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 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 (M) */ +/* > 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 eigenvalues 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 */ +/* > <= N: if INFO = i, then i eigenvectors failed to converge. */ +/* > Their indices are stored in IFAIL. */ +/* > > N: DPBSTF returned an error code; i.e., */ +/* > 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 doubleOTHEReigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n, + integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal * + bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl, + doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer + *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, + integer *iwork, integer *ifail, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + + /* Local variables */ + integer indd, inde; + char vect[1]; + logical test; + integer itmp1, i__, j, indee; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer iinfo; + char order[1]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + logical upper, wantz; + integer jj; + logical alleig, indeig; + integer indibl; + logical valeig; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), dpbstf_(char *, integer *, + integer *, doublereal *, integer *, integer *), dsbtrd_( + char *, char *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *); + integer indisp; + extern /* Subroutine */ int dsbgst_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *), + dstein_(integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *); + integer indiwo; + 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 *); + integer indwrk; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer nsplit; + doublereal 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1 * 1; + bb -= bb_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --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 (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ka < 0) { + *info = -5; + } else if (*kb < 0 || *kb > *ka) { + *info = -6; + } else if (*ldab < *ka + 1) { + *info = -8; + } else if (*ldbb < *kb + 1) { + *info = -10; + } else if (*ldq < 1 || wantz && *ldq < *n) { + *info = -12; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -14; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -15; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -16; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -21; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGVX", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Form a split Cholesky factorization of B. */ + + dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem. */ + + dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, + &q[q_offset], ldq, &work[1], &iinfo); + +/* Reduce symmetric band matrix to tridiagonal form. */ + + indd = 1; + inde = indd + *n; + indwrk = inde + *n; + if (wantz) { + *(unsigned char *)vect = 'U'; + } else { + *(unsigned char *)vect = 'N'; + } + dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &work[indd], &work[inde], + &q[q_offset], ldq, &work[indwrk], &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + if (! wantz) { + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, */ +/* call DSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde], + m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], + &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply transformation matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1); + dgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, & + c_b27, &z__[j * z_dim1 + 1], &c__1); +/* L20: */ + } + } + +L30: + +/* 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]; + } +/* L40: */ + } + + 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; + dswap_(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; + } + } +/* L50: */ + } + } + + return 0; + +/* End of DSBGVX */ + +} /* dsbgvx_ */ + diff --git a/lapack-netlib/SRC/dsbtrd.c b/lapack-netlib/SRC/dsbtrd.c new file mode 100644 index 000000000..d4fc3bdc8 --- /dev/null +++ b/lapack-netlib/SRC/dsbtrd.c @@ -0,0 +1,1161 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSBTRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSBTRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, */ +/* WORK, INFO ) */ + +/* CHARACTER UPLO, VECT */ +/* INTEGER INFO, KD, LDAB, LDQ, N */ +/* DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSBTRD reduces a real symmetric band matrix A to symmetric */ +/* > tridiagonal form T by an orthogonal similarity transformation: */ +/* > Q**T * A * Q = T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > = 'N': do not form Q; */ +/* > = 'V': form Q; */ +/* > = 'U': update a matrix X, by forming X*Q. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > On exit, the diagonal elements of AB are overwritten by the */ +/* > diagonal elements of the tridiagonal matrix T; if KD > 0, the */ +/* > elements on the first superdiagonal (if UPLO = 'U') or the */ +/* > first subdiagonal (if UPLO = 'L') are overwritten by the */ +/* > off-diagonal elements of T; the rest of AB is overwritten by */ +/* > values generated during the reduction. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The off-diagonal elements of the tridiagonal matrix T: */ +/* > E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > On entry, if VECT = 'U', then Q must contain an N-by-N */ +/* > matrix X; if VECT = 'N' or 'V', then Q need not be set. */ +/* > */ +/* > On exit: */ +/* > if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; */ +/* > if VECT = 'U', Q contains the product X*Q; */ +/* > if VECT = 'N', the array Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Modified by Linda Kaufman, Bell Labs. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsbtrd_(char *vect, char *uplo, integer *n, integer *kd, + doublereal *ab, integer *ldab, doublereal *d__, doublereal *e, + doublereal *q, integer *ldq, doublereal *work, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4, + i__5; + + /* Local variables */ + integer inca, jend, lend, jinc, incx, last; + doublereal temp; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer j1end, j1inc, i__, j, k, l, iqend; + extern logical lsame_(char *, char *); + logical initq, wantq, upper; + integer i2, j1, j2; + extern /* Subroutine */ int dlar2v_(integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + integer nq, nr, iqaend; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), xerbla_(char *, integer *, ftnlen), dlargv_( + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *), dlartv_(integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + integer kd1, ibl, iqb, kdn, jin, nrt, kdm1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + initq = lsame_(vect, "V"); + wantq = initq || lsame_(vect, "U"); + upper = lsame_(uplo, "U"); + kd1 = *kd + 1; + kdm1 = *kd - 1; + incx = *ldab - 1; + iqend = 1; + + *info = 0; + if (! wantq && ! lsame_(vect, "N")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < kd1) { + *info = -6; + } else if (*ldq < f2cmax(1,*n) && wantq) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBTRD", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Initialize Q to the unit matrix, if needed */ + + if (initq) { + dlaset_("Full", n, n, &c_b9, &c_b10, &q[q_offset], ldq); + } + +/* Wherever possible, plane rotations are generated and applied in */ +/* vector operations of length NR over the index set J1:J2:KD1. */ + +/* The cosines and sines of the plane rotations are stored in the */ +/* arrays D and WORK. */ + + inca = kd1 * *ldab; +/* Computing MIN */ + i__1 = *n - 1; + kdn = f2cmin(i__1,*kd); + if (upper) { + + if (*kd > 1) { + +/* Reduce to tridiagonal form, working with upper triangle */ + + nr = 0; + j1 = kdn + 2; + j2 = 1; + + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Reduce i-th row of matrix to tridiagonal form */ + + for (k = kdn + 1; k >= 2; --k) { + j1 += kdn; + j2 += kdn; + + if (nr > 0) { + +/* generate plane rotations to annihilate nonzero */ +/* elements which have been created outside the band */ + + dlargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, & + work[j1], &kd1, &d__[j1], &kd1); + +/* apply rotations from the right */ + + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + if (nr >= (*kd << 1) - 1) { + i__2 = *kd - 1; + for (l = 1; l <= i__2; ++l) { + dlartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1], + &inca, &ab[l + j1 * ab_dim1], &inca, & + d__[j1], &work[j1], &kd1); +/* L10: */ + } + + } else { + jend = j1 + (nr - 1) * kd1; + i__2 = jend; + i__3 = kd1; + for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <= + i__2; jinc += i__3) { + drot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], & + c__1, &ab[jinc * ab_dim1 + 1], &c__1, + &d__[jinc], &work[jinc]); +/* L20: */ + } + } + } + + + if (k > 2) { + if (k <= *n - i__ + 1) { + +/* generate plane rotation to annihilate a(i,i+k-1) */ +/* within the band */ + + dlartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] + , &ab[*kd - k + 2 + (i__ + k - 1) * + ab_dim1], &d__[i__ + k - 1], &work[i__ + + k - 1], &temp); + ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] = temp; + +/* apply rotation from the right */ + + i__3 = k - 3; + drot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) * + ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ + + k - 1) * ab_dim1], &c__1, &d__[i__ + k - + 1], &work[i__ + k - 1]); + } + ++nr; + j1 = j1 - kdn - 1; + } + +/* apply plane rotations from both sides to diagonal */ +/* blocks */ + + if (nr > 0) { + dlar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 + + j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca, + &d__[j1], &work[j1], &kd1); + } + +/* apply plane rotations from the left */ + + if (nr > 0) { + if ((*kd << 1) - 1 < nr) { + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + i__3 = *kd - 1; + for (l = 1; l <= i__3; ++l) { + if (j2 + l > *n) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + dlartv_(&nrt, &ab[*kd - l + (j1 + l) * + ab_dim1], &inca, &ab[*kd - l + 1 + + (j1 + l) * ab_dim1], &inca, & + d__[j1], &work[j1], &kd1); + } +/* L30: */ + } + } else { + j1end = j1 + kd1 * (nr - 2); + if (j1end >= j1) { + i__3 = j1end; + i__2 = kd1; + for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <= + i__3; jin += i__2) { + i__4 = *kd - 1; + drot_(&i__4, &ab[*kd - 1 + (jin + 1) * + ab_dim1], &incx, &ab[*kd + (jin + + 1) * ab_dim1], &incx, &d__[jin], & + work[jin]); +/* L40: */ + } + } +/* Computing MIN */ + i__2 = kdm1, i__3 = *n - j2; + lend = f2cmin(i__2,i__3); + last = j1end + kd1; + if (lend > 0) { + drot_(&lend, &ab[*kd - 1 + (last + 1) * + ab_dim1], &incx, &ab[*kd + (last + 1) + * ab_dim1], &incx, &d__[last], &work[ + last]); + } + } + } + + if (wantq) { + +/* accumulate product of plane rotations in Q */ + + if (initq) { + +/* take advantage of the fact that Q was */ +/* initially the Identity matrix */ + + iqend = f2cmax(iqend,j2); +/* Computing MAX */ + i__2 = 0, i__3 = k - 3; + i2 = f2cmax(i__2,i__3); + iqaend = i__ * *kd + 1; + if (k == 2) { + iqaend += *kd; + } + iqaend = f2cmin(iqaend,iqend); + i__2 = j2; + i__3 = kd1; + for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j + += i__3) { + ibl = i__ - i2 / kdm1; + ++i2; +/* Computing MAX */ + i__4 = 1, i__5 = j - ibl; + iqb = f2cmax(i__4,i__5); + nq = iqaend + 1 - iqb; +/* Computing MIN */ + i__4 = iqaend + *kd; + iqaend = f2cmin(i__4,iqend); + drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1, + &q[iqb + j * q_dim1], &c__1, &d__[j], + &work[j]); +/* L50: */ + } + } else { + + i__3 = j2; + i__2 = kd1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j + += i__2) { + drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[ + j * q_dim1 + 1], &c__1, &d__[j], & + work[j]); +/* L60: */ + } + } + + } + + if (j2 + kdn > *n) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 = j2 - kdn - 1; + } + + i__2 = j2; + i__3 = kd1; + for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) + { + +/* create nonzero element a(j-1,j+kd) outside the band */ +/* and store it in WORK */ + + work[j + *kd] = work[j] * ab[(j + *kd) * ab_dim1 + 1]; + ab[(j + *kd) * ab_dim1 + 1] = d__[j] * ab[(j + *kd) * + ab_dim1 + 1]; +/* L70: */ + } +/* L80: */ + } +/* L90: */ + } + } + + if (*kd > 0) { + +/* copy off-diagonal elements to E */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[*kd + (i__ + 1) * ab_dim1]; +/* L100: */ + } + } else { + +/* set E to zero if original matrix was diagonal */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = 0.; +/* L110: */ + } + } + +/* copy diagonal elements to D */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[kd1 + i__ * ab_dim1]; +/* L120: */ + } + + } else { + + if (*kd > 1) { + +/* Reduce to tridiagonal form, working with lower triangle */ + + nr = 0; + j1 = kdn + 2; + j2 = 1; + + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Reduce i-th column of matrix to tridiagonal form */ + + for (k = kdn + 1; k >= 2; --k) { + j1 += kdn; + j2 += kdn; + + if (nr > 0) { + +/* generate plane rotations to annihilate nonzero */ +/* elements which have been created outside the band */ + + dlargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, & + work[j1], &kd1, &d__[j1], &kd1); + +/* apply plane rotations from one side */ + + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + if (nr > (*kd << 1) - 1) { + i__3 = *kd - 1; + for (l = 1; l <= i__3; ++l) { + dlartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) * + ab_dim1], &inca, &ab[kd1 - l + 1 + ( + j1 - kd1 + l) * ab_dim1], &inca, &d__[ + j1], &work[j1], &kd1); +/* L130: */ + } + } else { + jend = j1 + kd1 * (nr - 1); + i__3 = jend; + i__2 = kd1; + for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <= + i__3; jinc += i__2) { + drot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1] + , &incx, &ab[kd1 + (jinc - *kd) * + ab_dim1], &incx, &d__[jinc], &work[ + jinc]); +/* L140: */ + } + } + + } + + if (k > 2) { + if (k <= *n - i__ + 1) { + +/* generate plane rotation to annihilate a(i+k-1,i) */ +/* within the band */ + + dlartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ * + ab_dim1], &d__[i__ + k - 1], &work[i__ + + k - 1], &temp); + ab[k - 1 + i__ * ab_dim1] = temp; + +/* apply rotation from the left */ + + i__2 = k - 3; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + drot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], & + i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], & + i__4, &d__[i__ + k - 1], &work[i__ + k - + 1]); + } + ++nr; + j1 = j1 - kdn - 1; + } + +/* apply plane rotations from both sides to diagonal */ +/* blocks */ + + if (nr > 0) { + dlar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 * + ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], & + inca, &d__[j1], &work[j1], &kd1); + } + +/* apply plane rotations from the right */ + + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + if (nr > 0) { + if (nr > (*kd << 1) - 1) { + i__2 = *kd - 1; + for (l = 1; l <= i__2; ++l) { + if (j2 + l > *n) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + dlartv_(&nrt, &ab[l + 2 + (j1 - 1) * + ab_dim1], &inca, &ab[l + 1 + j1 * + ab_dim1], &inca, &d__[j1], &work[ + j1], &kd1); + } +/* L150: */ + } + } else { + j1end = j1 + kd1 * (nr - 2); + if (j1end >= j1) { + i__2 = j1end; + i__3 = kd1; + for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 : + j1inc <= i__2; j1inc += i__3) { + drot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 + + 3], &c__1, &ab[j1inc * ab_dim1 + + 2], &c__1, &d__[j1inc], &work[ + j1inc]); +/* L160: */ + } + } +/* Computing MIN */ + i__3 = kdm1, i__2 = *n - j2; + lend = f2cmin(i__3,i__2); + last = j1end + kd1; + if (lend > 0) { + drot_(&lend, &ab[(last - 1) * ab_dim1 + 3], & + c__1, &ab[last * ab_dim1 + 2], &c__1, + &d__[last], &work[last]); + } + } + } + + + + if (wantq) { + +/* accumulate product of plane rotations in Q */ + + if (initq) { + +/* take advantage of the fact that Q was */ +/* initially the Identity matrix */ + + iqend = f2cmax(iqend,j2); +/* Computing MAX */ + i__3 = 0, i__2 = k - 3; + i2 = f2cmax(i__3,i__2); + iqaend = i__ * *kd + 1; + if (k == 2) { + iqaend += *kd; + } + iqaend = f2cmin(iqaend,iqend); + i__3 = j2; + i__2 = kd1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j + += i__2) { + ibl = i__ - i2 / kdm1; + ++i2; +/* Computing MAX */ + i__4 = 1, i__5 = j - ibl; + iqb = f2cmax(i__4,i__5); + nq = iqaend + 1 - iqb; +/* Computing MIN */ + i__4 = iqaend + *kd; + iqaend = f2cmin(i__4,iqend); + drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1, + &q[iqb + j * q_dim1], &c__1, &d__[j], + &work[j]); +/* L170: */ + } + } else { + + i__2 = j2; + i__3 = kd1; + for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j + += i__3) { + drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[ + j * q_dim1 + 1], &c__1, &d__[j], & + work[j]); +/* L180: */ + } + } + } + + if (j2 + kdn > *n) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 = j2 - kdn - 1; + } + + i__3 = j2; + i__2 = kd1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) + { + +/* create nonzero element a(j+kd,j-1) outside the */ +/* band and store it in WORK */ + + work[j + *kd] = work[j] * ab[kd1 + j * ab_dim1]; + ab[kd1 + j * ab_dim1] = d__[j] * ab[kd1 + j * ab_dim1] + ; +/* L190: */ + } +/* L200: */ + } +/* L210: */ + } + } + + if (*kd > 0) { + +/* copy off-diagonal elements to E */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[i__ * ab_dim1 + 2]; +/* L220: */ + } + } else { + +/* set E to zero if original matrix was diagonal */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = 0.; +/* L230: */ + } + } + +/* copy diagonal elements to D */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[i__ * ab_dim1 + 1]; +/* L240: */ + } + } + + return 0; + +/* End of DSBTRD */ + +} /* dsbtrd_ */ + diff --git a/lapack-netlib/SRC/dsfrk.c b/lapack-netlib/SRC/dsfrk.c new file mode 100644 index 000000000..378d5a854 --- /dev/null +++ b/lapack-netlib/SRC/dsfrk.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 \b DSFRK performs a symmetric rank-k operation for matrix in RFP format. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSFRK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, */ +/* C ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER K, LDA, N */ +/* CHARACTER TRANS, TRANSR, UPLO */ +/* DOUBLE PRECISION A( LDA, * ), C( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 3 BLAS like routine for C in RFP Format. */ +/* > */ +/* > DSFRK performs one of the symmetric rank--k operations */ +/* > */ +/* > C := alpha*A*A**T + beta*C, */ +/* > */ +/* > or */ +/* > */ +/* > C := alpha*A**T*A + beta*C, */ +/* > */ +/* > where alpha and beta are real scalars, C is an n--by--n symmetric */ +/* > 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; */ +/* > = 'T': The 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**T + beta*C. */ +/* > */ +/* > TRANS = 'T' or 't' C := alpha*A**T*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 = 'T' */ +/* > or 't', 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (NT) */ +/* > NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP */ +/* > Format. RFP Format is described by TRANSR, UPLO and N. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsfrk_(char *transr, char *uplo, char *trans, integer *n, + integer *k, doublereal *alpha, doublereal *a, integer *lda, + doublereal *beta, doublereal *c__) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer info, j; + logical normaltransr; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + integer nrowa; + logical lower; + extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + integer n1, n2, nk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd, notrans; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + 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, "T")) { + info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + info = -2; + } else if (! notrans && ! lsame_(trans, "T")) { + 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_("DSFRK ", &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 DSYRK 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) { + c__[j] = 0.; + } + return 0; + } + +/* 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' */ + + dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], n); + dsyrk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[*n + 1], n); + dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n); + + } else { + +/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ + + dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], n); + dsyrk_("U", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[*n + 1], n) + ; + dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &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' */ + + dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 + 1], n); + dsyrk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda, + beta, &c__[n1 + 1], n); + dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[n2 + a_dim1], lda, beta, &c__[1], n); + + } else { + +/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ + + dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 + 1], n); + dsyrk_("U", "T", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda, + beta, &c__[n1 + 1], n); + dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[n2 * a_dim1 + 1], lda, beta, &c__[1], n); + + } + + } + + } else { + +/* N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ + + dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], &n1); + dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[2], &n1); + dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[n1 + 1 + a_dim1], lda, beta, &c__[n1 * n1 + 1], + &n1); + + } else { + +/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ + + dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], &n1); + dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[2], &n1); + dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[n1 * + n1 + 1], &n1); + + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ + + dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 * n2 + 1], &n2); + dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[n1 * n2 + 1], &n2); + dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[1], &n2); + + } else { + +/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ + + dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 * n2 + 1], &n2); + dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[n1 * n2 + 1], &n2); + dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &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; + dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[1], &i__1); + i__1 = *n + 1; + dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], & + i__1); + + } else { + +/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ + + i__1 = *n + 1; + dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[1], &i__1); + i__1 = *n + 1; + dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &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; + dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[nk + 1], &i__1); + i__1 = *n + 1; + dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[nk + 1 + a_dim1], lda, beta, &c__[1], &i__1); + + } else { + +/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ + + i__1 = *n + 1; + dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[nk + 1], &i__1); + i__1 = *n + 1; + dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], & + i__1); + + } + + } + + } else { + +/* N is even, and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ + + dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 1], &nk); + dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[1], &nk); + dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[nk + 1 + a_dim1], lda, beta, &c__[(nk + 1) * + nk + 1], &nk); + + } else { + +/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ + + dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 1], &nk); + dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[1], &nk); + dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[(nk + + 1) * nk + 1], &nk); + + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ + + dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk * (nk + 1) + 1], &nk); + dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[nk * nk + 1], &nk); + dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[1], &nk); + + } else { + +/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ + + dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk * (nk + 1) + 1], &nk); + dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[nk * nk + 1], &nk); + dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], & + nk); + + } + + } + + } + + } + + return 0; + +/* End of DSFRK */ + +} /* dsfrk_ */ + diff --git a/lapack-netlib/SRC/dsgesv.c b/lapack-netlib/SRC/dsgesv.c new file mode 100644 index 000000000..bd1f0d852 --- /dev/null +++ b/lapack-netlib/SRC/dsgesv.c @@ -0,0 +1,863 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSGESV computes the solution to system of linear equations A * X = B for GE matrices (mixe +d precision with iterative refinement) */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSGESV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, */ +/* SWORK, ITER, INFO ) */ + +/* INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* REAL SWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSGESV computes the solution to a real system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ +/* > */ +/* > DSGESV first attempts to factorize the matrix in SINGLE PRECISION */ +/* > and use this factorization within an iterative refinement procedure */ +/* > to produce a solution with DOUBLE PRECISION normwise backward error */ +/* > quality (see below). If the approach fails the method switches to a */ +/* > DOUBLE PRECISION factorization and solve. */ +/* > */ +/* > The iterative refinement is not going to be a winning strategy if */ +/* > the ratio SINGLE PRECISION performance over DOUBLE PRECISION */ +/* > performance is too small. A reasonable strategy should take the */ +/* > number of right-hand sides and the size of the matrix into account. */ +/* > This might be done with a call to ILAENV in the future. Up to now, we */ +/* > always try iterative refinement. */ +/* > */ +/* > The iterative refinement process is stopped if */ +/* > ITER > ITERMAX */ +/* > or for all the RHS we have: */ +/* > RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ +/* > where */ +/* > o ITER is the number of the current iteration in the iterative */ +/* > refinement process */ +/* > o RNRM is the infinity-norm of the residual */ +/* > o XNRM is the infinity-norm of the solution */ +/* > o ANRM is the infinity-operator-norm of the matrix A */ +/* > o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ +/* > The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ +/* > respectively. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, */ +/* > dimension (LDA,N) */ +/* > On entry, the N-by-N coefficient matrix A. */ +/* > On exit, if iterative refinement has been successfully used */ +/* > (INFO = 0 and ITER >= 0, see description below), then A is */ +/* > unchanged, if double precision factorization has been used */ +/* > (INFO = 0 and ITER < 0, see description below), then the */ +/* > array A contains the factors L and U from the factorization */ +/* > A = P*L*U; the unit diagonal elements of L are not stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices that define the permutation matrix P; */ +/* > row i of the matrix was interchanged with row IPIV(i). */ +/* > Corresponds either to the single precision factorization */ +/* > (if INFO = 0 and ITER >= 0) or the double precision */ +/* > factorization (if INFO = 0 and ITER < 0). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N,NRHS) */ +/* > This array is used to hold the residual vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SWORK */ +/* > \verbatim */ +/* > SWORK is REAL array, dimension (N*(N+NRHS)) */ +/* > This array is used to use the single precision matrix and the */ +/* > right-hand sides or solutions in single precision. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ITER */ +/* > \verbatim */ +/* > ITER is INTEGER */ +/* > < 0: iterative refinement has failed, double precision */ +/* > factorization has been performed */ +/* > -1 : the routine fell back to full precision for */ +/* > implementation- or machine-specific reasons */ +/* > -2 : narrowing the precision induced an overflow, */ +/* > the routine fell back to full precision */ +/* > -3 : failure of SGETRF */ +/* > -31: stop the iterative refinement after the 30th */ +/* > iterations */ +/* > > 0: iterative refinement has been successfully used. */ +/* > Returns the number of iterations */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is */ +/* > exactly zero. The factorization has been completed, */ +/* > but the factor U is exactly singular, so the solution */ +/* > could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleGEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dsgesv_(integer *n, integer *nrhs, doublereal *a, + integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal * + x, integer *ldx, doublereal *work, real *swork, integer *iter, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, + x_dim1, x_offset, i__1; + doublereal d__1; + + /* Local variables */ + doublereal anrm; + integer ptsa; + doublereal rnrm, xnrm; + integer ptsx, i__; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + integer iiter; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dlag2s_(integer *, integer *, + doublereal *, integer *, real *, integer *, integer *), slag2d_( + integer *, integer *, real *, integer *, doublereal *, integer *, + integer *); + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + dgetrf_(integer *, integer *, doublereal *, integer *, integer *, + integer *), xerbla_(char *, integer *, ftnlen), dgetrs_(char *, + integer *, integer *, doublereal *, integer *, integer *, + doublereal *, integer *, integer *), sgetrf_(integer *, + integer *, real *, integer *, integer *, integer *), sgetrs_(char + *, integer *, integer *, real *, integer *, integer *, real *, + integer *, integer *); + doublereal cte, eps; + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + + + + + + /* Parameter adjustments */ + work_dim1 = *n; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --swork; + + /* Function Body */ + *info = 0; + *iter = 0; + +/* Test the input parameters. */ + + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldx < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSGESV", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if (N.EQ.0). */ + + if (*n == 0) { + return 0; + } + +/* Skip single precision iterative refinement if a priori slower */ +/* than double precision factorization. */ + + if (FALSE_) { + *iter = -1; + goto L40; + } + +/* Compute some constants. */ + + anrm = dlange_("I", n, n, &a[a_offset], lda, &work[work_offset]); + eps = dlamch_("Epsilon"); + cte = anrm * eps * sqrt((doublereal) (*n)) * 1.; + +/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ + + ptsa = 1; + ptsx = ptsa + *n * *n; + +/* Convert B from double precision to single precision and store the */ +/* result in SX. */ + + dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Convert A from double precision to single precision and store the */ +/* result in SA. */ + + dlag2s_(n, n, &a[a_offset], lda, &swork[ptsa], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Compute the LU factorization of SA. */ + + sgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info); + + if (*info != 0) { + *iter = -3; + goto L40; + } + +/* Solve the system SA*SX = SB. */ + + sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx], + n, info); + +/* Convert SX back to double precision */ + + slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); + +/* Compute R = B - AX (R is WORK). */ + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[a_offset], + lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * + x_dim1], abs(d__1)); + rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + + i__ * work_dim1], abs(d__1)); + if (rnrm > xnrm * cte) { + goto L10; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion. We are good to exit. */ + + *iter = 0; + return 0; + +L10: + + for (iiter = 1; iiter <= 30; ++iiter) { + +/* Convert R (in WORK) from double precision to single precision */ +/* and store the result in SX. */ + + dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Solve the system SA*SX = SR. */ + + sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ + ptsx], n, info); + +/* Convert SX back to double precision and update the current */ +/* iterate. */ + + slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * + x_dim1 + 1], &c__1); + } + +/* Compute R = B - AX (R is WORK). */ + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[ + a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset], + n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=IITER>0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * + x_dim1], abs(d__1)); + rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + + i__ * work_dim1], abs(d__1)); + if (rnrm > xnrm * cte) { + goto L20; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion, we are good to exit. */ + + *iter = iiter; + + return 0; + +L20: + +/* L30: */ + ; + } + +/* If we are at this place of the code, this is because we have */ +/* performed ITER=ITERMAX iterations and never satisfied the */ +/* stopping criterion, set up the ITER flag accordingly and follow up */ +/* on double precision routine. */ + + *iter = -31; + +L40: + +/* Single-precision iterative refinement failed to converge to a */ +/* satisfactory solution, so we resort to double precision. */ + + dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); + + if (*info != 0) { + return 0; + } + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset] + , ldx, info); + + return 0; + +/* End of DSGESV. */ + +} /* dsgesv_ */ + diff --git a/lapack-netlib/SRC/dspcon.c b/lapack-netlib/SRC/dspcon.c new file mode 100644 index 000000000..d57c48ad7 --- /dev/null +++ b/lapack-netlib/SRC/dspcon.c @@ -0,0 +1,633 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPCON estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a real symmetric packed matrix A using the factorization */ +/* > A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */ +/* > */ +/* > 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**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] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION 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 DSPTRF, 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 DSPTRF. */ +/* > \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 DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dspcon_(char *uplo, integer *n, doublereal *ap, integer * + ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer + *iwork, integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer kase, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int dsptrs_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --iwork; + --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_("DSPCON", &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__) { + if (ipiv[i__] > 0 && ap[ip] == 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__) { + if (ipiv[i__] > 0 && ap[ip] == 0.) { + return 0; + } + ip = ip + *n - i__ + 1; +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + dsptrs_(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 DSPCON */ + +} /* dspcon_ */ + diff --git a/lapack-netlib/SRC/dspev.c b/lapack-netlib/SRC/dspev.c new file mode 100644 index 000000000..3e57499c0 --- /dev/null +++ b/lapack-netlib/SRC/dspev.c @@ -0,0 +1,676 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSPEV 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 DSPEV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDZ, N */ +/* DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPEV computes all the eigenvalues and, optionally, eigenvectors of a */ +/* > real symmetric matrix A 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dspev_(char *jobz, char *uplo, integer *n, doublereal * + ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, + 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); + doublereal bignum; + extern doublereal dlansp_(char *, char *, integer *, doublereal *, + doublereal *); + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + integer indwrk; + extern /* Subroutine */ int dopgtr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *), dsptrd_(char *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *), dsteqr_(char *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + doublereal smlnum, 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; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lsame_(uplo, "U") || lsame_(uplo, + "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPEV ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = ap[1]; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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 = dlansp_("M", uplo, n, &ap[1], &work[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; + dscal_(&i__1, &sigma, &ap[1], &c__1); + } + +/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DOPGTR to generate the orthogonal matrix, then call DSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + indwrk = indtau + *n; + dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[ + indwrk], &iinfo); + dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ + indtau], 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 DSPEV */ + +} /* dspev_ */ + diff --git a/lapack-netlib/SRC/dspevd.c b/lapack-netlib/SRC/dspevd.c new file mode 100644 index 000000000..117423abc --- /dev/null +++ b/lapack-netlib/SRC/dspevd.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 DSPEVD 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 DSPEVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, */ +/* IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDZ, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPEVD computes all the eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 must be at least 1. */ +/* > If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be at least */ +/* > 1 + 6*N + N**2. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the required sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 the 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 and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dspevd_(char *jobz, char *uplo, integer *n, doublereal * + ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, + integer *lwork, 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, rmin, rmax; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo, lwmin; + logical wantz; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *, integer *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal dlansp_(char *, char *, integer *, doublereal *, + doublereal *); + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + integer indwrk, liwmin; + extern /* Subroutine */ int dsptrd_(char *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *), + dopmtr_(char *, char *, char *, integer *, integer *, doublereal * + , doublereal *, doublereal *, integer *, doublereal *, integer *); + integer llwork; + doublereal smlnum; + logical lquery; + 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; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lsame_(uplo, "U") || lsame_(uplo, + "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -7; + } + + if (*info == 0) { + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + i__1 * i__1; + } else { + liwmin = 1; + lwmin = *n << 1; + } + } + iwork[1] = liwmin; + work[1] = (doublereal) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -9; + } else if (*liwork < liwmin && ! lquery) { + *info = -11; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPEVD", &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]; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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 = dlansp_("M", uplo, n, &ap[1], &work[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; + dscal_(&i__1, &sigma, &ap[1], &c__1); + } + +/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ +/* tridiagonal matrix, then call DOPMTR to multiply it by the */ +/* Householder transformations represented in AP. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + dstedc_("I", n, &w[1], &work[inde], &z__[z_offset], ldz, &work[indwrk] + , &llwork, &iwork[1], liwork, info); + dopmtr_("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) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSPEVD */ + +} /* dspevd_ */ + diff --git a/lapack-netlib/SRC/dspevx.c b/lapack-netlib/SRC/dspevx.c new file mode 100644 index 000000000..83e952bfb --- /dev/null +++ b/lapack-netlib/SRC/dspevx.c @@ -0,0 +1,937 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSPEVX 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 DSPEVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, */ +/* ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, */ +/* INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, LDZ, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (8*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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dspevx_(char *jobz, char *range, char *uplo, integer *n, + doublereal *ap, doublereal *vl, doublereal *vu, integer *il, integer * + iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, 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 *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + logical wantz; + integer jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, indibl; + logical valeig; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal abstll, bignum; + extern doublereal dlansp_(char *, char *, integer *, doublereal *, + doublereal *); + integer indtau, indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo; + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *); + integer indwrk; + extern /* Subroutine */ int dopgtr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *), dsptrd_(char *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *), dsteqr_(char *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dopmtr_(char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + integer nsplit; + doublereal smlnum, 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; + --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_("DSPEVX", &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]; + } else { + if (*vl < ap[1] && *vu >= ap[1]) { + *m = 1; + w[1] = ap[1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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 = dlansp_("M", uplo, n, &ap[1], &work[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; + dscal_(&i__1, &sigma, &ap[1], &c__1); + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ + + indtau = 1; + inde = indtau + *n; + indd = inde + *n; + indwrk = indd + *n; + dsptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or DOPGTR and SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, & + work[indwrk], &iinfo); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], 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, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + dopmtr_("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; + dswap_(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 DSPEVX */ + +} /* dspevx_ */ + diff --git a/lapack-netlib/SRC/dspgst.c b/lapack-netlib/SRC/dspgst.c new file mode 100644 index 000000000..83a3d917c --- /dev/null +++ b/lapack-netlib/SRC/dspgst.c @@ -0,0 +1,715 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPGST */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPGST + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, ITYPE, N */ +/* DOUBLE PRECISION AP( * ), BP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPGST reduces a real symmetric-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**T)*A*inv(U) or inv(L)*A*inv(L**T) */ +/* > */ +/* > 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**T or L**T*A*L. */ +/* > */ +/* > B must have been previously factorized as U**T*U or L*L**T by DPPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITYPE */ +/* > \verbatim */ +/* > ITYPE is INTEGER */ +/* > = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ +/* > = 2 or 3: compute U*A*U**T or L**T*A*L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored and B is factored as */ +/* > U**T*U; */ +/* > = 'L': Lower triangle of A is stored and B is factored as */ +/* > L*L**T. */ +/* > \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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, if INFO = 0, the transformed matrix, stored in the */ +/* > same format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BP */ +/* > \verbatim */ +/* > BP is DOUBLE PRECISION 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 DPPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n, + doublereal *ap, doublereal *bp, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *); + integer j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dspmv_(char *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + logical upper; + integer j1, k1; + extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *), + dtpsv_(char *, char *, char *, integer *, doublereal *, + doublereal *, integer *); + integer jj, kk; + doublereal ct; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + 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_("DSPGST", &i__1, (ftnlen)6); + return 0; + } + + if (*itype == 1) { + if (upper) { + +/* Compute inv(U**T)*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 */ + + bjj = bp[jj]; + dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], & + c__1); + i__2 = j - 1; + dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, & + ap[j1], &c__1); + i__2 = j - 1; + d__1 = 1. / bjj; + dscal_(&i__2, &d__1, &ap[j1], &c__1); + i__2 = j - 1; + ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], & + c__1)) / bjj; +/* L10: */ + } + } else { + +/* Compute inv(L)*A*inv(L**T) */ + +/* 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) */ + + akk = ap[kk]; + bkk = bp[kk]; +/* Computing 2nd power */ + d__1 = bkk; + akk /= d__1 * d__1; + ap[kk] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &ap[kk + 1], &c__1); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) + ; + i__2 = *n - k; + dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1] + , &c__1, &ap[k1k1]); + i__2 = *n - k; + daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) + ; + i__2 = *n - k; + dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], + &ap[kk + 1], &c__1); + } + kk = k1k1; +/* L20: */ + } + } + } else { + if (upper) { + +/* Compute U*A*U**T */ + +/* 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) */ + + akk = ap[kk]; + bkk = bp[kk]; + i__2 = k - 1; + dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ + k1], &c__1); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); + i__2 = k - 1; + dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, & + ap[1]); + i__2 = k - 1; + daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); + i__2 = k - 1; + dscal_(&i__2, &bkk, &ap[k1], &c__1); +/* Computing 2nd power */ + d__1 = bkk; + ap[kk] = akk * (d__1 * d__1); +/* L30: */ + } + } else { + +/* Compute L**T *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 */ + + ajj = ap[jj]; + bjj = bp[jj]; + i__2 = *n - j; + ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj + + 1], &c__1); + i__2 = *n - j; + dscal_(&i__2, &bjj, &ap[jj + 1], &c__1); + i__2 = *n - j; + dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, & + c_b11, &ap[jj + 1], &c__1); + i__2 = *n - j + 1; + dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj], + &c__1); + jj = j1j1; +/* L40: */ + } + } + } + return 0; + +/* End of DSPGST */ + +} /* dspgst_ */ + diff --git a/lapack-netlib/SRC/dspgv.c b/lapack-netlib/SRC/dspgv.c new file mode 100644 index 000000000..78104a9a7 --- /dev/null +++ b/lapack-netlib/SRC/dspgv.c @@ -0,0 +1,687 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPGV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, */ +/* INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, ITYPE, LDZ, N */ +/* DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPGV computes all the eigenvalues and, optionally, the eigenvectors */ +/* > of a real generalized symmetric-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 symmetric, 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric 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**T*U or B = L*L**T, 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 DOUBLE PRECISION 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**T*B*Z = I; */ +/* > if ITYPE = 3, Z**T*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 DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: DPPTRF or DSPEV returned an error code: */ +/* > <= N: if INFO = i, DSPEV failed to converge; */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to 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 June 2017 */ + +/* > \ingroup doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dspgv_(integer *itype, char *jobz, char *uplo, integer * + n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + integer neig, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dspev_(char *, char *, integer *, doublereal * + , doublereal *, doublereal *, integer *, doublereal *, integer *); + char trans[1]; + logical upper; + extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *), + dtpsv_(char *, char *, char *, integer *, doublereal *, + doublereal *, integer *); + logical wantz; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpptrf_( + char *, integer *, doublereal *, integer *), dspgst_( + integer *, char *, integer *, doublereal *, doublereal *, integer + *); + + +/* -- 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; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* 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_("DSPGV ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dspgst_(itype, uplo, n, &ap[1], &bp[1], info); + dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[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)**T*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpsv_(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**T*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + return 0; + +/* End of DSPGV */ + +} /* dspgv_ */ + diff --git a/lapack-netlib/SRC/dspgvd.c b/lapack-netlib/SRC/dspgvd.c new file mode 100644 index 000000000..a2f846632 --- /dev/null +++ b/lapack-netlib/SRC/dspgvd.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 DSPGVD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPGVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, */ +/* LWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPGVD computes all the eigenvalues, and optionally, the eigenvectors */ +/* > of a real generalized symmetric-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 symmetric, 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric 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**T*U or B = L*L**T, 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 DOUBLE PRECISION 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**T*B*Z = I; */ +/* > if ITYPE = 3, Z**T*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 DOUBLE PRECISION 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 >= 2*N. */ +/* > If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the required sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 the 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 and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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: DPPTRF or DSPEVD returned an error code: */ +/* > <= N: if INFO = i, DSPEVD failed to converge; */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to 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 doubleOTHEReigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer * + n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, integer *lwork, 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; + extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *), + dtpsv_(char *, char *, char *, integer *, doublereal *, + doublereal *, integer *); + logical wantz; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dspevd_( + char *, char *, integer *, doublereal *, doublereal *, doublereal + *, integer *, doublereal *, integer *, integer *, integer *, + integer *); + integer liwmin; + extern /* Subroutine */ int dpptrf_(char *, integer *, doublereal *, + integer *), dspgst_(integer *, char *, integer *, + doublereal *, doublereal *, integer *); + logical lquery; + + +/* -- 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; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -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) { + liwmin = 1; + lwmin = 1; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = *n << 1; + } + } + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPGVD", &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 BP. */ + + dpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dspgst_(itype, uplo, n, &ap[1], &bp[1], info); + dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], + lwork, &iwork[1], liwork, info); +/* Computing MAX */ + d__1 = (doublereal) lwmin; + lwmin = (integer) f2cmax(d__1,work[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)**T *y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpsv_(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**T *y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSPGVD */ + +} /* dspgvd_ */ + diff --git a/lapack-netlib/SRC/dspgvx.c b/lapack-netlib/SRC/dspgvx.c new file mode 100644 index 000000000..1fae46fed --- /dev/null +++ b/lapack-netlib/SRC/dspgvx.c @@ -0,0 +1,826 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPGVX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPGVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, */ +/* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, 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 AP( * ), BP( * ), W( * ), WORK( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPGVX computes selected eigenvalues, and optionally, eigenvectors */ +/* > of a real generalized symmetric-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 symmetric, stored in packed storage, 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 triangle of A and B are stored; */ +/* > = 'L': Lower triangle of A and B are stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix pencil (A,B). N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric 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**T*U or B = L*L**T, 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 A 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 DOUBLE PRECISION array, dimension (LDZ, f2cmax(1,M)) */ +/* > 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**T*B*Z = I; */ +/* > if ITYPE = 3, Z**T*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 DOUBLE PRECISION array, dimension (8*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: DPPTRF or DSPEVX returned an error code: */ +/* > <= N: if INFO = i, DSPEVX 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 doubleOTHEReigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dspgvx_(integer *itype, char *jobz, char *range, char * + uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *vl, + doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer + *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, + 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; + extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *), + dtpsv_(char *, char *, char *, integer *, doublereal *, + doublereal *, integer *); + logical wantz, alleig, indeig, valeig; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpptrf_( + char *, integer *, doublereal *, integer *), dspgst_( + integer *, char *, integer *, doublereal *, doublereal *, integer + *), dspevx_(char *, char *, char *, integer *, doublereal + *, doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, 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..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + upper = lsame_(uplo, "U"); + wantz = lsame_(jobz, "V"); + 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_("DSPGVX", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dspgst_(itype, uplo, n, &ap[1], &bp[1], info); + dspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & + z__[z_offset], ldz, &work[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)**T*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dtpsv_(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**T*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + + return 0; + +/* End of DSPGVX */ + +} /* dspgvx_ */ + diff --git a/lapack-netlib/SRC/dsposv.c b/lapack-netlib/SRC/dsposv.c new file mode 100644 index 000000000..a31e575b0 --- /dev/null +++ b/lapack-netlib/SRC/dsposv.c @@ -0,0 +1,863 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSPOSV computes the solution to system of linear equations A * X = B for PO matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPOSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, */ +/* SWORK, ITER, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS */ +/* REAL SWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPOSV computes the solution to a real system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric positive definite matrix and X and B */ +/* > are N-by-NRHS matrices. */ +/* > */ +/* > DSPOSV first attempts to factorize the matrix in SINGLE PRECISION */ +/* > and use this factorization within an iterative refinement procedure */ +/* > to produce a solution with DOUBLE PRECISION normwise backward error */ +/* > quality (see below). If the approach fails the method switches to a */ +/* > DOUBLE PRECISION factorization and solve. */ +/* > */ +/* > The iterative refinement is not going to be a winning strategy if */ +/* > the ratio SINGLE PRECISION performance over DOUBLE PRECISION */ +/* > performance is too small. A reasonable strategy should take the */ +/* > number of right-hand sides and the size of the matrix into account. */ +/* > This might be done with a call to ILAENV in the future. Up to now, we */ +/* > always try iterative refinement. */ +/* > */ +/* > The iterative refinement process is stopped if */ +/* > ITER > ITERMAX */ +/* > or for all the RHS we have: */ +/* > RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ +/* > where */ +/* > o ITER is the number of the current iteration in the iterative */ +/* > refinement process */ +/* > o RNRM is the infinity-norm of the residual */ +/* > o XNRM is the infinity-norm of the solution */ +/* > o ANRM is the infinity-operator-norm of the matrix A */ +/* > o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ +/* > The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ +/* > respectively. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, */ +/* > dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, if iterative refinement has been successfully used */ +/* > (INFO = 0 and ITER >= 0, see description below), then A is */ +/* > unchanged, if double precision factorization has been used */ +/* > (INFO = 0 and ITER < 0, see description below), then the */ +/* > array A contains the factor U or L from the Cholesky */ +/* > factorization A = U**T*U or A = L*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The 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 DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N,NRHS) */ +/* > This array is used to hold the residual vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SWORK */ +/* > \verbatim */ +/* > SWORK is REAL array, dimension (N*(N+NRHS)) */ +/* > This array is used to use the single precision matrix and the */ +/* > right-hand sides or solutions in single precision. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ITER */ +/* > \verbatim */ +/* > ITER is INTEGER */ +/* > < 0: iterative refinement has failed, double precision */ +/* > factorization has been performed */ +/* > -1 : the routine fell back to full precision for */ +/* > implementation- or machine-specific reasons */ +/* > -2 : narrowing the precision induced an overflow, */ +/* > the routine fell back to full precision */ +/* > -3 : failure of SPOTRF */ +/* > -31: stop the iterative refinement after the 30th */ +/* > iterations */ +/* > > 0: iterative refinement has been successfully used. */ +/* > Returns the number of iterations */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i of (DOUBLE */ +/* > PRECISION) A is not positive definite, so the */ +/* > factorization could not be completed, and the solution */ +/* > has not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doublePOsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dsposv_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + x, integer *ldx, doublereal *work, real *swork, integer *iter, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, + x_dim1, x_offset, i__1; + doublereal d__1; + + /* Local variables */ + doublereal anrm; + integer ptsa; + doublereal rnrm, xnrm; + integer ptsx, i__; + extern logical lsame_(char *, char *); + integer iiter; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dsymm_(char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), dlag2s_(integer *, integer *, doublereal *, + integer *, real *, integer *, integer *), slag2d_(integer *, + integer *, real *, integer *, doublereal *, integer *, integer *), + dlat2s_(char *, integer *, doublereal *, integer *, real *, + integer *, integer *); + extern doublereal dlamch_(char *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *, + integer *, integer *), dpotrs_(char *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotrs_(char *, integer *, integer *, real *, integer *, + real *, integer *, integer *); + doublereal cte, eps; + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + + + + + + /* Parameter adjustments */ + work_dim1 = *n; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --swork; + + /* Function Body */ + *info = 0; + *iter = 0; + +/* Test the input parameters. */ + + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldx < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPOSV", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if (N.EQ.0). */ + + if (*n == 0) { + return 0; + } + +/* Skip single precision iterative refinement if a priori slower */ +/* than double precision factorization. */ + + if (FALSE_) { + *iter = -1; + goto L40; + } + +/* Compute some constants. */ + + anrm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[work_offset]); + eps = dlamch_("Epsilon"); + cte = anrm * eps * sqrt((doublereal) (*n)) * 1.; + +/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ + + ptsa = 1; + ptsx = ptsa + *n * *n; + +/* Convert B from double precision to single precision and store the */ +/* result in SX. */ + + dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Convert A from double precision to single precision and store the */ +/* result in SA. */ + + dlat2s_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Compute the Cholesky factorization of SA. */ + + spotrf_(uplo, n, &swork[ptsa], n, info); + + if (*info != 0) { + *iter = -3; + goto L40; + } + +/* Solve the system SA*SX = SB. */ + + spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); + +/* Convert SX back to double precision */ + + slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); + +/* Compute R = B - AX (R is WORK). */ + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + dsymm_("Left", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], + ldx, &c_b11, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * + x_dim1], abs(d__1)); + rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + + i__ * work_dim1], abs(d__1)); + if (rnrm > xnrm * cte) { + goto L10; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion. We are good to exit. */ + + *iter = 0; + return 0; + +L10: + + for (iiter = 1; iiter <= 30; ++iiter) { + +/* Convert R (in WORK) from double precision to single precision */ +/* and store the result in SX. */ + + dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Solve the system SA*SX = SR. */ + + spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); + +/* Convert SX back to double precision and update the current */ +/* iterate. */ + + slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * + x_dim1 + 1], &c__1); + } + +/* Compute R = B - AX (R is WORK). */ + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + dsymm_("L", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], + ldx, &c_b11, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=IITER>0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * + x_dim1], abs(d__1)); + rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + + i__ * work_dim1], abs(d__1)); + if (rnrm > xnrm * cte) { + goto L20; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion, we are good to exit. */ + + *iter = iiter; + + return 0; + +L20: + +/* L30: */ + ; + } + +/* If we are at this place of the code, this is because we have */ +/* performed ITER=ITERMAX iterations and never satisfied the */ +/* stopping criterion, set up the ITER flag accordingly and follow */ +/* up on double precision routine. */ + + *iter = -31; + +L40: + +/* Single-precision iterative refinement failed to converge to a */ +/* satisfactory solution, so we resort to double precision. */ + + dpotrf_(uplo, n, &a[a_offset], lda, info); + + if (*info != 0) { + return 0; + } + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info); + + return 0; + +/* End of DSPOSV. */ + +} /* dsposv_ */ + diff --git a/lapack-netlib/SRC/dsprfs.c b/lapack-netlib/SRC/dsprfs.c new file mode 100644 index 000000000..ac2a70034 --- /dev/null +++ b/lapack-netlib/SRC/dsprfs.c @@ -0,0 +1,873 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, */ +/* FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), */ +/* $ FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is symmetric 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the symmetric matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFP */ +/* > \verbatim */ +/* > AFP is DOUBLE PRECISION 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**T or */ +/* > A = L*D*L**T as computed by DSPTRF, 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 DSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by DSPTRS. */ +/* > 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 DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs, + doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, + integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, + doublereal *berr, doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), daxpy_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + integer count; + extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + logical upper; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, 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 dsptrs_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, 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; + --iwork; + + /* 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_("DSPRFS", &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 */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, & + work[*n + 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__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + kk = 1; + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + ik = kk; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; + s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * + x_dim1], abs(d__2)); + ++ik; +/* L40: */ + } + work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk + + s; + kk += k; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + work[k] += (d__1 = ap[kk], abs(d__1)) * xk; + ik = kk + 1; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; + s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * + x_dim1], abs(d__2)); + ++ik; +/* L60: */ + } + work[k] += s; + kk += *n - k + 1; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = f2cmax(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(d__2,d__3); + } +/* 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. */ + + dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info); + daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(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 DLACN2 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 (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**T). */ + + dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, + info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L120: */ + } + dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, + info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = f2cmax(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DSPRFS */ + +} /* dsprfs_ */ + diff --git a/lapack-netlib/SRC/dspsv.c b/lapack-netlib/SRC/dspsv.c new file mode 100644 index 000000000..b0dd150b7 --- /dev/null +++ b/lapack-netlib/SRC/dspsv.c @@ -0,0 +1,614 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSPSV 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 DSPSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPSV computes the solution to a real system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric 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**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, D is symmetric 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > 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**T or A = L*D*L**T as computed by DSPTRF, 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 DSPTRF. 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 DOUBLE PRECISION 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 doubleOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the symmetric matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = aji) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dspsv_(char *uplo, integer *n, integer *nrhs, doublereal + *ap, integer *ipiv, doublereal *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), dsptrf_( + char *, integer *, doublereal *, integer *, integer *), + dsptrs_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, 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_("DSPSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + dsptrf_(uplo, n, &ap[1], &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dsptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info); + + } + return 0; + +/* End of DSPSV */ + +} /* dspsv_ */ + diff --git a/lapack-netlib/SRC/dspsvx.c b/lapack-netlib/SRC/dspsvx.c new file mode 100644 index 000000000..73e455e7d --- /dev/null +++ b/lapack-netlib/SRC/dspsvx.c @@ -0,0 +1,795 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSPSVX 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 DSPSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, */ +/* LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER FACT, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), */ +/* $ FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */ +/* > A = L*D*L**T to compute the solution to a real system of linear */ +/* > equations A * X = B, where A is an N-by-N symmetric 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**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > 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. AP, 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the symmetric matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFP */ +/* > \verbatim */ +/* > AFP is DOUBLE PRECISION 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**T or A = L*D*L**T as computed by DSPTRF, 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**T or A = L*D*L**T as computed by DSPTRF, 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 DSPTRF. */ +/* > 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 DSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 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 doubleOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the symmetric matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = aji) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dspsvx_(char *fact, char *uplo, integer *n, integer * + nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, + integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, + doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, + 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 dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + extern doublereal dlamch_(char *); + logical nofact; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + extern doublereal dlansp_(char *, char *, integer *, doublereal *, + doublereal *); + extern /* Subroutine */ int dspcon_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + integer *), dsprfs_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *), dsptrf_(char *, integer *, + doublereal *, integer *, integer *), dsptrs_(char *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *); + + +/* -- 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..-- */ +/* 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; + --iwork; + + /* 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_("DSPSVX", &i__1, (ftnlen)6); + return 0; + } + + if (nofact) { + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + i__1 = *n * (*n + 1) / 2; + dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); + dsptrf_(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 = dlansp_("I", uplo, n, &ap[1], &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], &iwork[1], + info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dsptrs_(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. */ + + dsprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[ + x_offset], ldx, &ferr[1], &berr[1], &work[1], &iwork[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 DSPSVX */ + +} /* dspsvx_ */ + diff --git a/lapack-netlib/SRC/dsptrd.c b/lapack-netlib/SRC/dsptrd.c new file mode 100644 index 000000000..f9e8a5f79 --- /dev/null +++ b/lapack-netlib/SRC/dsptrd.c @@ -0,0 +1,712 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPTRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPTRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPTRD reduces a real symmetric matrix A stored in packed form to */ +/* > symmetric tridiagonal form T by an orthogonal similarity */ +/* > transformation: Q**T * 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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(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 orthogonal */ +/* > 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 orthogonal 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 DOUBLE PRECISION 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 doubleOTHERcomputational */ + +/* > \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**T */ +/* > */ +/* > where tau is a real scalar, and v is a real 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**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */ +/* > overwriting A(i+2:n,i), and tau is stored in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsptrd_(char *uplo, integer *n, doublereal *ap, + doublereal *d__, doublereal *e, doublereal *tau, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal taui; + extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *); + integer i__; + doublereal alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dspmv_(char *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + integer i1; + logical upper; + integer ii; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *), xerbla_(char *, integer *, ftnlen); + 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_("DSPTRD", &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; + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) = I - tau * v * v**T */ +/* to annihilate A(1:i-1,i+1) */ + + dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui); + e[i__] = ap[i1 + i__ - 1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(1:i,1:i) */ + + ap[i1 + i__ - 1] = 1.; + +/* Compute y := tau * A * v storing y in TAU(1:i) */ + + dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[ + 1], &c__1); + +/* Compute w := y - 1/2 * tau * (y**T *v) * v */ + + alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], & + c__1); + daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w**T - w * v**T */ + + dspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, & + ap[1]); + + ap[i1 + i__ - 1] = e[i__]; + } + d__[i__ + 1] = ap[i1 + i__]; + tau[i__] = taui; + i1 -= i__; +/* L10: */ + } + d__[1] = ap[1]; + } 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; + 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**T */ +/* to annihilate A(i+2:n,i) */ + + i__2 = *n - i__; + dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui); + e[i__] = ap[ii + 1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ + + ap[ii + 1] = 1.; + +/* Compute y := tau * A * v storing y in TAU(i:n-1) */ + + i__2 = *n - i__; + dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & + c_b8, &tau[i__], &c__1); + +/* Compute w := y - 1/2 * tau * (y**T *v) * v */ + + i__2 = *n - i__; + alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii + + 1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w**T - w * v**T */ + + i__2 = *n - i__; + dspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], & + c__1, &ap[i1i1]); + + ap[ii + 1] = e[i__]; + } + d__[i__] = ap[ii]; + tau[i__] = taui; + ii = i1i1; +/* L20: */ + } + d__[*n] = ap[ii]; + } + + return 0; + +/* End of DSPTRD */ + +} /* dsptrd_ */ + diff --git a/lapack-netlib/SRC/dsptrf.c b/lapack-netlib/SRC/dsptrf.c new file mode 100644 index 000000000..a31464801 --- /dev/null +++ b/lapack-netlib/SRC/dsptrf.c @@ -0,0 +1,1052 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPTRF computes the factorization of a real symmetric matrix A stored */ +/* > in packed format using the Bunch-Kaufman diagonal pivoting method: */ +/* > */ +/* > A = U*D*U**T or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > \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 DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the 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 doubleOTHERcomputational */ + +/* > \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: */ +/* ================== */ +/* > */ +/* > J. Lewis, Boeing Computer Services Company */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer * + ipiv, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer imax, jmax; + extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *); + integer i__, j, k; + doublereal t, alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer kstep; + logical upper; + doublereal r1, d11, d12, d21, d22; + integer kc, kk, kp; + doublereal absakk, wk; + integer kx; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal colmax, rowmax; + integer knc, kpc, npp; + doublereal 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_("DSPTRF", &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**T 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 */ + + absakk = (d__1 = ap[kc + k - 1], 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 = idamax_(&i__1, &ap[kc], &c__1); + colmax = (d__1 = ap[kc + imax - 1], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + + rowmax = 0.; + jmax = imax; + kx = imax * (imax + 1) / 2 + imax; + i__1 = k; + for (j = imax + 1; j <= i__1; ++j) { + if ((d__1 = ap[kx], abs(d__1)) > rowmax) { + rowmax = (d__1 = ap[kx], abs(d__1)); + jmax = j; + } + kx += j; +/* L20: */ + } + kpc = (imax - 1) * imax / 2 + 1; + if (imax > 1) { + i__1 = imax - 1; + jmax = idamax_(&i__1, &ap[kpc], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], abs( + d__1)); + rowmax = f2cmax(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = ap[kpc + imax - 1], 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; + dswap_(&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; + t = ap[knc + j - 1]; + ap[knc + j - 1] = ap[kx]; + ap[kx] = t; +/* L30: */ + } + t = ap[knc + kk - 1]; + ap[knc + kk - 1] = ap[kpc + kp - 1]; + ap[kpc + kp - 1] = t; + if (kstep == 2) { + t = ap[kc + k - 2]; + ap[kc + k - 2] = ap[kc + kp - 1]; + ap[kc + kp - 1] = t; + } + } + +/* 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)**T = A - W(k)*1/D(k)*W(k)**T */ + + r1 = 1. / ap[kc + k - 1]; + i__1 = k - 1; + d__1 = -r1; + dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]); + +/* Store U(k) in column k */ + + i__1 = k - 1; + dscal_(&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) )**T */ +/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T */ + + if (k > 2) { + + d12 = ap[k - 1 + (k - 1) * k / 2]; + d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12; + d11 = ap[k + (k - 1) * k / 2] / d12; + t = 1. / (d11 * d22 - 1.); + d12 = t / d12; + + for (j = k - 2; j >= 1; --j) { + wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] - + ap[j + (k - 1) * k / 2]); + wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k + - 2) * (k - 1) / 2]); + for (i__ = j; i__ >= 1; --i__) { + ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j / + 2] - ap[i__ + (k - 1) * k / 2] * wk - ap[ + i__ + (k - 2) * (k - 1) / 2] * wkm1; +/* L40: */ + } + ap[j + (k - 1) * k / 2] = wk; + ap[j + (k - 2) * (k - 1) / 2] = wkm1; +/* 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**T 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 */ + + absakk = (d__1 = ap[kc], 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 + idamax_(&i__1, &ap[kc + 1], &c__1); + colmax = (d__1 = ap[kc + imax - k], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* 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) { + if ((d__1 = ap[kx], abs(d__1)) > rowmax) { + rowmax = (d__1 = ap[kx], abs(d__1)); + 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 + idamax_(&i__1, &ap[kpc + 1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], abs( + d__1)); + rowmax = f2cmax(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = ap[kpc], 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; + dswap_(&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; + t = ap[knc + j - kk]; + ap[knc + j - kk] = ap[kx]; + ap[kx] = t; +/* L80: */ + } + t = ap[knc]; + ap[knc] = ap[kpc]; + ap[kpc] = t; + if (kstep == 2) { + t = ap[kc + 1]; + ap[kc + 1] = ap[kc + kp - k]; + ap[kc + kp - k] = t; + } + } + +/* 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)**T = A - W(k)*(1/D(k))*W(k)**T */ + + r1 = 1. / ap[kc]; + i__1 = *n - k; + d__1 = -r1; + dspr_(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; + dscal_(&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) )**T */ +/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th */ +/* columns of L */ + + d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]; + d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21; + d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) / + 2] - ap[j + k * ((*n << 1) - k - 1) / 2]); + wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) / + 2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]); + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__ + + (j - 1) * ((*n << 1) - j) / 2] - ap[i__ + + (k - 1) * ((*n << 1) - k) / 2] * wk - + ap[i__ + k * ((*n << 1) - k - 1) / 2] * + wkp1; +/* L90: */ + } + + ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk; + ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1; + +/* 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 DSPTRF */ + +} /* dsptrf_ */ + diff --git a/lapack-netlib/SRC/dsptri.c b/lapack-netlib/SRC/dsptri.c new file mode 100644 index 000000000..2428a6e59 --- /dev/null +++ b/lapack-netlib/SRC/dsptri.c @@ -0,0 +1,836 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPTRI computes the inverse of a real symmetric indefinite matrix */ +/* > A in packed storage using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by DSPTRF. */ +/* > \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] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION 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 DSPTRF, */ +/* > stored as a packed triangular matrix. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) 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 DSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsptri_(char *uplo, integer *n, doublereal *ap, integer * + ipiv, doublereal *work, integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal temp, akkp1, d__; + integer j, k; + doublereal t; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer kstep; + extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + logical upper; + 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_("DSPTRI", &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)) { + if (ipiv[*info] > 0 && ap[kp] == 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)) { + if (ipiv[*info] > 0 && ap[kp] == 0.) { + return 0; + } + kp = kp + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + 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. */ + + ap[kc + k - 1] = 1. / ap[kc + k - 1]; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & + ap[kc], &c__1); + i__1 = k - 1; + ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], & + c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = ap[kcnext + k - 1], abs(d__1)); + ak = ap[kc + k - 1] / t; + akp1 = ap[kcnext + k] / t; + akkp1 = ap[kcnext + k - 1] / t; + d__ = t * (ak * akp1 - 1.); + ap[kc + k - 1] = akp1 / d__; + ap[kcnext + k] = ak / d__; + ap[kcnext + k - 1] = -akkp1 / d__; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & + ap[kc], &c__1); + i__1 = k - 1; + ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], & + c__1); + i__1 = k - 1; + ap[kcnext + k - 1] -= ddot_(&i__1, &ap[kc], &c__1, &ap[kcnext] + , &c__1); + i__1 = k - 1; + dcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1); + i__1 = k - 1; + dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & + ap[kcnext], &c__1); + i__1 = k - 1; + ap[kcnext + k] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext], & + c__1); + } + 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; + dswap_(&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; + temp = ap[kc + j - 1]; + ap[kc + j - 1] = ap[kx]; + ap[kx] = temp; +/* L40: */ + } + temp = ap[kc + k - 1]; + ap[kc + k - 1] = ap[kpc + kp - 1]; + ap[kpc + kp - 1] = temp; + if (kstep == 2) { + temp = ap[kc + k + k - 1]; + ap[kc + k + k - 1] = ap[kc + k + kp - 1]; + ap[kc + k + kp - 1] = temp; + } + } + + k += kstep; + kc = kcnext; + goto L30; +L50: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + 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. */ + + ap[kc] = 1. / ap[kc]; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dspmv_(uplo, &i__1, &c_b11, &ap[kc + *n - k + 1], &work[1], & + c__1, &c_b13, &ap[kc + 1], &c__1); + i__1 = *n - k; + ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = ap[kcnext + 1], abs(d__1)); + ak = ap[kcnext] / t; + akp1 = ap[kc] / t; + akkp1 = ap[kcnext + 1] / t; + d__ = t * (ak * akp1 - 1.); + ap[kcnext] = akp1 / d__; + ap[kc] = ak / d__; + ap[kcnext + 1] = -akkp1 / d__; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], + &c__1, &c_b13, &ap[kc + 1], &c__1); + i__1 = *n - k; + ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1); + i__1 = *n - k; + ap[kcnext + 1] -= ddot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext + + 2], &c__1); + i__1 = *n - k; + dcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1); + i__1 = *n - k; + dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], + &c__1, &c_b13, &ap[kcnext + 2], &c__1); + i__1 = *n - k; + ap[kcnext] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext + 2], & + c__1); + } + 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; + dswap_(&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; + temp = ap[kc + j - k]; + ap[kc + j - k] = ap[kx]; + ap[kx] = temp; +/* L70: */ + } + temp = ap[kc]; + ap[kc] = ap[kpc]; + ap[kpc] = temp; + if (kstep == 2) { + temp = ap[kc - *n + k - 1]; + ap[kc - *n + k - 1] = ap[kc - *n + kp - 1]; + ap[kc - *n + kp - 1] = temp; + } + } + + k -= kstep; + kc = kcnext; + goto L60; +L80: + ; + } + + return 0; + +/* End of DSPTRI */ + +} /* dsptri_ */ + diff --git a/lapack-netlib/SRC/dsptrs.c b/lapack-netlib/SRC/dsptrs.c new file mode 100644 index 000000000..44fff5f87 --- /dev/null +++ b/lapack-netlib/SRC/dsptrs.c @@ -0,0 +1,887 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSPTRS solves a system of linear equations A*X = B with a real */ +/* > symmetric matrix A stored in packed format using the factorization */ +/* > A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION 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 DSPTRF, 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 DSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsptrs_(char *uplo, integer *n, integer *nrhs, + doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal akm1k; + integer j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal denom; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dswap_(integer *, + doublereal *, integer *, doublereal *, integer *); + logical upper; + doublereal ak, bk; + integer kc, kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --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_("DSPTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* First solve U*D*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + 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) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[ + b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / ap[kc + k - 1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K-1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k - 1) { + dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in columns K-1 and K of A. */ + + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[ + b_dim1 + 1], ldb); + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &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. */ + + akm1k = ap[kc + k - 2]; + akm1 = ap[kc - 1] / akm1k; + ak = ap[kc + k - 1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k - 1 + j * b_dim1] / akm1k; + bk = b[k + j * b_dim1] / akm1k; + b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L20: */ + } + kc = kc - k + 1; + k += -2; + } + + goto L10; +L30: + +/* Next solve U**T*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + 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**T(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc] + , &c__1, &c_b19, &b[k + b_dim1], ldb); + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc += k; + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc] + , &c__1, &c_b19, &b[k + b_dim1], ldb); + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc + + k], &c__1, &c_b19, &b[k + 1 + b_dim1], ldb); + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc = kc + (k << 1) + 1; + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* First solve L*D*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + 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) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dger_(&i__1, nrhs, &c_b7, &ap[kc + 1], &c__1, &b[k + b_dim1], + ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / ap[kc]; + dscal_(nrhs, &d__1, &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) { + dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k < *n - 1) { + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &ap[kc + 2], &c__1, &b[k + b_dim1], + ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &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. */ + + akm1k = ap[kc + 1]; + akm1 = ap[kc] / akm1k; + ak = ap[kc + *n - k + 1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k + j * b_dim1] / akm1k; + bk = b[k + 1 + j * b_dim1] / akm1k; + b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L70: */ + } + kc = kc + (*n - k << 1) + 1; + k += 2; + } + + goto L60; +L80: + +/* Next solve L**T*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + 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**T(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &ap[kc - (*n - k)], &c__1, &c_b19, &b[k - 1 + + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc -= *n - k + 2; + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of DSPTRS */ + +} /* dsptrs_ */ + diff --git a/lapack-netlib/SRC/dstebz.c b/lapack-netlib/SRC/dstebz.c new file mode 100644 index 000000000..c65d2a4df --- /dev/null +++ b/lapack-netlib/SRC/dstebz.c @@ -0,0 +1,1248 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSTEBZ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSTEBZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, */ +/* M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER ORDER, RANGE */ +/* INTEGER IL, INFO, IU, M, N, NSPLIT */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEBZ computes the eigenvalues of a symmetric tridiagonal */ +/* > matrix T. The user may ask for all eigenvalues, all eigenvalues */ +/* > in the half-open interval (VL, VU], or the IL-th through IU-th */ +/* > eigenvalues. */ +/* > */ +/* > To avoid overflow, the matrix must be scaled so that its */ +/* > largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest + */ +/* > accuracy, it should not be much smaller than that. */ +/* > */ +/* > See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* > Matrix", Report CS41, Computer Science Dept., Stanford */ +/* > University, July 21, 1966. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': ("All") all eigenvalues will be found. */ +/* > = 'V': ("Value") all eigenvalues in the half-open interval */ +/* > (VL, VU] will be found. */ +/* > = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ +/* > entire matrix) will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ORDER */ +/* > \verbatim */ +/* > ORDER is CHARACTER*1 */ +/* > = 'B': ("By Block") the eigenvalues will be grouped by */ +/* > split-off block (see IBLOCK, ISPLIT) and */ +/* > ordered from smallest to largest within */ +/* > the block. */ +/* > = 'E': ("Entire matrix") */ +/* > the eigenvalues for the entire matrix */ +/* > will be ordered from smallest to */ +/* > largest. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the tridiagonal matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION */ +/* > */ +/* > If RANGE='V', the lower bound of the interval to */ +/* > be searched for eigenvalues. Eigenvalues less than or equal */ +/* > to VL, or greater than VU, will not be returned. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is DOUBLE PRECISION */ +/* > */ +/* > If RANGE='V', the upper bound of the interval to */ +/* > be searched for eigenvalues. Eigenvalues less than or equal */ +/* > to VL, or greater than VU, will not be returned. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > smallest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IU */ +/* > \verbatim */ +/* > IU is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > largest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ABSTOL */ +/* > \verbatim */ +/* > ABSTOL is DOUBLE PRECISION */ +/* > The absolute tolerance for the eigenvalues. An eigenvalue */ +/* > (or cluster) is considered to be located if it has been */ +/* > determined to lie in an interval whose width is ABSTOL or */ +/* > less. If ABSTOL is less than or equal to zero, then ULP*|T| */ +/* > will be used, where |T| means the 1-norm of T. */ +/* > */ +/* > Eigenvalues will be computed most accurately when ABSTOL is */ +/* > set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) off-diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The actual number of eigenvalues found. 0 <= M <= N. */ +/* > (See also the description of INFO=2,3.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NSPLIT */ +/* > \verbatim */ +/* > NSPLIT is INTEGER */ +/* > The number of diagonal blocks in the matrix T. */ +/* > 1 <= NSPLIT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, the first M elements of W will contain the */ +/* > eigenvalues. (DSTEBZ may use the remaining N-M elements as */ +/* > workspace.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IBLOCK */ +/* > \verbatim */ +/* > IBLOCK is INTEGER array, dimension (N) */ +/* > At each row/column j where E(j) is zero or small, the */ +/* > matrix T is considered to split into a block diagonal */ +/* > matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */ +/* > block (from 1 to the number of blocks) the eigenvalue W(i) */ +/* > belongs. (DSTEBZ may use the remaining N-M elements as */ +/* > workspace.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into submatrices. */ +/* > The first submatrix consists of rows/columns 1 to ISPLIT(1), */ +/* > the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* > etc., and the NSPLIT-th consists of rows/columns */ +/* > ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ +/* > (Only the first NSPLIT elements will actually be used, but */ +/* > since the user cannot know a priori what value NSPLIT will */ +/* > have, N words must be reserved for ISPLIT.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: some or all of the eigenvalues failed to converge or */ +/* > were not computed: */ +/* > =1 or 3: Bisection failed to converge for some */ +/* > eigenvalues; these eigenvalues are flagged by a */ +/* > negative block number. The effect is that the */ +/* > eigenvalues may not be as accurate as the */ +/* > absolute and relative tolerances. This is */ +/* > generally caused by unexpectedly inaccurate */ +/* > arithmetic. */ +/* > =2 or 3: RANGE='I' only: Not all of the eigenvalues */ +/* > IL:IU were found. */ +/* > Effect: M < IU+1-IL */ +/* > Cause: non-monotonic arithmetic, causing the */ +/* > Sturm sequence to be non-monotonic. */ +/* > Cure: recalculate, using RANGE='A', and pick */ +/* > out eigenvalues IL:IU. In some cases, */ +/* > increasing the PARAMETER "FUDGE" may */ +/* > make things work. */ +/* > = 4: RANGE='I', and the Gershgorin interval */ +/* > initially used was too small. No eigenvalues */ +/* > were computed. */ +/* > Probable cause: your machine has sloppy */ +/* > floating-point arithmetic. */ +/* > Cure: Increase the PARAMETER "FUDGE", */ +/* > recompile, and try again. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > RELFAC DOUBLE PRECISION, default = 2.0e0 */ +/* > The relative tolerance. An interval (a,b] lies within */ +/* > "relative tolerance" if b-a < RELFAC*ulp*f2cmax(|a|,|b|), */ +/* > where "ulp" is the machine precision (distance from 1 to */ +/* > the next larger floating point number.) */ +/* > */ +/* > FUDGE DOUBLE PRECISION, default = 2 */ +/* > A "fudge factor" to widen the Gershgorin intervals. Ideally, */ +/* > a value of 1 should work, but on machines with sloppy */ +/* > arithmetic, this needs to be larger. The default for */ +/* > publicly released versions should be large enough to handle */ +/* > the worst machine around. Note that this has no effect */ +/* > on accuracy of the solution. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dstebz_(char *range, char *order, integer *n, doublereal + *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, + doublereal *d__, doublereal *e, integer *m, integer *nsplit, + doublereal *w, integer *iblock, integer *isplit, doublereal *work, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + integer iend, ioff, iout, itmp1, j, jdisc; + extern logical lsame_(char *, char *); + integer iinfo; + doublereal atoli; + integer iwoff; + doublereal bnorm; + integer itmax; + doublereal wkill, rtoli, tnorm; + integer ib, jb, ie, je, nb; + doublereal gl; + integer im, in; + extern doublereal dlamch_(char *); + integer ibegin; + doublereal gu; + integer iw; + extern /* Subroutine */ int dlaebz_(integer *, integer *, integer *, + integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + doublereal wl; + integer irange, idiscl; + doublereal safemn, wu; + integer idumma[1]; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer idiscu, iorder; + logical ncnvrg; + doublereal pivmin; + logical toofew; + integer nwl; + doublereal ulp, wlu, wul; + integer nwu; + doublereal tmp1, tmp2; + + +/* -- 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 */ + --iwork; + --work; + --isplit; + --iblock; + --w; + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Decode RANGE */ + + if (lsame_(range, "A")) { + irange = 1; + } else if (lsame_(range, "V")) { + irange = 2; + } else if (lsame_(range, "I")) { + irange = 3; + } else { + irange = 0; + } + +/* Decode ORDER */ + + if (lsame_(order, "B")) { + iorder = 2; + } else if (lsame_(order, "E")) { + iorder = 1; + } else { + iorder = 0; + } + +/* Check for Errors */ + + if (irange <= 0) { + *info = -1; + } else if (iorder <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (irange == 2) { + if (*vl >= *vu) { + *info = -5; + } + } else if (irange == 3 && (*il < 1 || *il > f2cmax(1,*n))) { + *info = -6; + } else if (irange == 3 && (*iu < f2cmin(*n,*il) || *iu > *n)) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEBZ", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize error flags */ + + *info = 0; + ncnvrg = FALSE_; + toofew = FALSE_; + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Simplifications: */ + + if (irange == 3 && *il == 1 && *iu == *n) { + irange = 1; + } + +/* Get machine constants */ +/* NB is the minimum vector length for vector bisection, or 0 */ +/* if only scalar is to be done. */ + + safemn = dlamch_("S"); + ulp = dlamch_("P"); + rtoli = ulp * 2.; + nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + if (nb <= 1) { + nb = 0; + } + +/* Special Case when N=1 */ + + if (*n == 1) { + *nsplit = 1; + isplit[1] = 1; + if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) { + *m = 0; + } else { + w[1] = d__[1]; + iblock[1] = 1; + *m = 1; + } + return 0; + } + +/* Compute Splitting Points */ + + *nsplit = 1; + work[*n] = 0.; + pivmin = 1.; + + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing 2nd power */ + d__1 = e[j - 1]; + tmp1 = d__1 * d__1; +/* Computing 2nd power */ + d__2 = ulp; + if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn + > tmp1) { + isplit[*nsplit] = j - 1; + ++(*nsplit); + work[j - 1] = 0.; + } else { + work[j - 1] = tmp1; + pivmin = f2cmax(pivmin,tmp1); + } +/* L10: */ + } + isplit[*nsplit] = *n; + pivmin *= safemn; + +/* Compute Interval and ATOLI */ + + if (irange == 3) { + +/* RANGE='I': Compute the interval containing eigenvalues */ +/* IL through IU. */ + +/* Compute Gershgorin interval for entire (split) matrix */ +/* and use it as the initial interval */ + + gu = d__[1]; + gl = d__[1]; + tmp1 = 0.; + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + tmp2 = sqrt(work[j]); +/* Computing MAX */ + d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; + gu = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; + gl = f2cmin(d__1,d__2); + tmp1 = tmp2; +/* L20: */ + } + +/* Computing MAX */ + d__1 = gu, d__2 = d__[*n] + tmp1; + gu = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[*n] - tmp1; + gl = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = abs(gl), d__2 = abs(gu); + tnorm = f2cmax(d__1,d__2); + gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002; + gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1; + +/* Compute Iteration parameters */ + + itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2; + if (*abstol <= 0.) { + atoli = ulp * tnorm; + } else { + atoli = *abstol; + } + + work[*n + 1] = gl; + work[*n + 2] = gl; + work[*n + 3] = gu; + work[*n + 4] = gu; + work[*n + 5] = gl; + work[*n + 6] = gu; + iwork[1] = -1; + iwork[2] = -1; + iwork[3] = *n + 1; + iwork[4] = *n + 1; + iwork[5] = *il - 1; + iwork[6] = *iu; + + dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin, + &d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n + + 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo); + + if (iwork[6] == *iu) { + wl = work[*n + 1]; + wlu = work[*n + 3]; + nwl = iwork[1]; + wu = work[*n + 4]; + wul = work[*n + 2]; + nwu = iwork[4]; + } else { + wl = work[*n + 2]; + wlu = work[*n + 4]; + nwl = iwork[2]; + wu = work[*n + 3]; + wul = work[*n + 1]; + nwu = iwork[3]; + } + + if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { + *info = 4; + return 0; + } + } else { + +/* RANGE='A' or 'V' -- Set ATOLI */ + +/* Computing MAX */ + d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + ( + d__2 = e[*n - 1], abs(d__2)); + tnorm = f2cmax(d__3,d__4); + + i__1 = *n - 1; + for (j = 2; j <= i__1; ++j) { +/* Computing MAX */ + d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1] + , abs(d__2)) + (d__3 = e[j], abs(d__3)); + tnorm = f2cmax(d__4,d__5); +/* L30: */ + } + + if (*abstol <= 0.) { + atoli = ulp * tnorm; + } else { + atoli = *abstol; + } + + if (irange == 2) { + wl = *vl; + wu = *vu; + } else { + wl = 0.; + wu = 0.; + } + } + +/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. */ +/* NWL accumulates the number of eigenvalues .le. WL, */ +/* NWU accumulates the number of eigenvalues .le. WU */ + + *m = 0; + iend = 0; + *info = 0; + nwl = 0; + nwu = 0; + + i__1 = *nsplit; + for (jb = 1; jb <= i__1; ++jb) { + ioff = iend; + ibegin = ioff + 1; + iend = isplit[jb]; + in = iend - ioff; + + if (in == 1) { + +/* Special Case -- IN=1 */ + + if (irange == 1 || wl >= d__[ibegin] - pivmin) { + ++nwl; + } + if (irange == 1 || wu >= d__[ibegin] - pivmin) { + ++nwu; + } + if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin] + - pivmin) { + ++(*m); + w[*m] = d__[ibegin]; + iblock[*m] = jb; + } + } else { + +/* General Case -- IN > 1 */ + +/* Compute Gershgorin Interval */ +/* and use it as the initial interval */ + + gu = d__[ibegin]; + gl = d__[ibegin]; + tmp1 = 0.; + + i__2 = iend - 1; + for (j = ibegin; j <= i__2; ++j) { + tmp2 = (d__1 = e[j], abs(d__1)); +/* Computing MAX */ + d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; + gu = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; + gl = f2cmin(d__1,d__2); + tmp1 = tmp2; +/* L40: */ + } + +/* Computing MAX */ + d__1 = gu, d__2 = d__[iend] + tmp1; + gu = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[iend] - tmp1; + gl = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = abs(gl), d__2 = abs(gu); + bnorm = f2cmax(d__1,d__2); + gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1; + gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1; + +/* Compute ATOLI for the current submatrix */ + + if (*abstol <= 0.) { +/* Computing MAX */ + d__1 = abs(gl), d__2 = abs(gu); + atoli = ulp * f2cmax(d__1,d__2); + } else { + atoli = *abstol; + } + + if (irange > 1) { + if (gu < wl) { + nwl += in; + nwu += in; + goto L70; + } + gl = f2cmax(gl,wl); + gu = f2cmin(gu,wu); + if (gl >= gu) { + goto L70; + } + } + +/* Set Up Initial Interval */ + + work[*n + 1] = gl; + work[*n + in + 1] = gu; + dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, & + pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & + w[*m + 1], &iblock[*m + 1], &iinfo); + + nwl += iwork[1]; + nwu += iwork[in + 1]; + iwoff = *m - iwork[1]; + +/* Compute Eigenvalues */ + + itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.) + ) + 2; + dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, & + pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], + &w[*m + 1], &iblock[*m + 1], &iinfo); + +/* Copy Eigenvalues Into W and IBLOCK */ +/* Use -JB for block number for unconverged eigenvalues. */ + + i__2 = iout; + for (j = 1; j <= i__2; ++j) { + tmp1 = (work[j + *n] + work[j + in + *n]) * .5; + +/* Flag non-convergence. */ + + if (j > iout - iinfo) { + ncnvrg = TRUE_; + ib = -jb; + } else { + ib = jb; + } + i__3 = iwork[j + in] + iwoff; + for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { + w[je] = tmp1; + iblock[je] = ib; +/* L50: */ + } +/* L60: */ + } + + *m += im; + } +L70: + ; + } + +/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */ +/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */ + + if (irange == 3) { + im = 0; + idiscl = *il - 1 - nwl; + idiscu = nwu - *iu; + + if (idiscl > 0 || idiscu > 0) { + i__1 = *m; + for (je = 1; je <= i__1; ++je) { + if (w[je] <= wlu && idiscl > 0) { + --idiscl; + } else if (w[je] >= wul && idiscu > 0) { + --idiscu; + } else { + ++im; + w[im] = w[je]; + iblock[im] = iblock[je]; + } +/* L80: */ + } + *m = im; + } + if (idiscl > 0 || idiscu > 0) { + +/* Code to deal with effects of bad arithmetic: */ +/* Some low eigenvalues to be discarded are not in (WL,WLU], */ +/* or high eigenvalues to be discarded are not in (WUL,WU] */ +/* so just kill off the smallest IDISCL/largest IDISCU */ +/* eigenvalues, by simply finding the smallest/largest */ +/* eigenvalue(s). */ + +/* (If N(w) is monotone non-decreasing, this should never */ +/* happen.) */ + + if (idiscl > 0) { + wkill = wu; + i__1 = idiscl; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L90: */ + } + iblock[iw] = 0; +/* L100: */ + } + } + if (idiscu > 0) { + + wkill = wl; + i__1 = idiscu; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L110: */ + } + iblock[iw] = 0; +/* L120: */ + } + } + im = 0; + i__1 = *m; + for (je = 1; je <= i__1; ++je) { + if (iblock[je] != 0) { + ++im; + w[im] = w[je]; + iblock[im] = iblock[je]; + } +/* L130: */ + } + *m = im; + } + if (idiscl < 0 || idiscu < 0) { + toofew = TRUE_; + } + } + +/* If ORDER='B', do nothing -- the eigenvalues are already sorted */ +/* by block. */ +/* If ORDER='E', sort the eigenvalues from smallest to largest */ + + if (iorder == 1 && *nsplit > 1) { + i__1 = *m - 1; + for (je = 1; je <= i__1; ++je) { + ie = 0; + tmp1 = w[je]; + i__2 = *m; + for (j = je + 1; j <= i__2; ++j) { + if (w[j] < tmp1) { + ie = j; + tmp1 = w[j]; + } +/* L140: */ + } + + if (ie != 0) { + itmp1 = iblock[ie]; + w[ie] = w[je]; + iblock[ie] = iblock[je]; + w[je] = tmp1; + iblock[je] = itmp1; + } +/* L150: */ + } + } + + *info = 0; + if (ncnvrg) { + ++(*info); + } + if (toofew) { + *info += 2; + } + return 0; + +/* End of DSTEBZ */ + +} /* dstebz_ */ + diff --git a/lapack-netlib/SRC/dstedc.c b/lapack-netlib/SRC/dstedc.c new file mode 100644 index 000000000..041d4ff8b --- /dev/null +++ b/lapack-netlib/SRC/dstedc.c @@ -0,0 +1,917 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSTEDC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSTEDC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, */ +/* LIWORK, INFO ) */ + +/* CHARACTER COMPZ */ +/* INTEGER INFO, LDZ, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEDC computes all eigenvalues and, optionally, eigenvectors of a */ +/* > symmetric tridiagonal matrix using the divide and conquer method. */ +/* > The eigenvectors of a full or band real symmetric matrix can also be */ +/* > found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this */ +/* > matrix to tridiagonal form. */ +/* > */ +/* > This code makes very mild assumptions about floating point */ +/* > arithmetic. It will work on machines with a guard digit in */ +/* > add/subtract, or on those binary machines without guard digits */ +/* > which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ +/* > It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. See DLAED3 for details. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only. */ +/* > = 'I': Compute eigenvectors of tridiagonal matrix also. */ +/* > = 'V': Compute eigenvectors of original dense symmetric */ +/* > matrix also. On entry, Z contains the orthogonal */ +/* > matrix used to reduce the original matrix to */ +/* > tridiagonal form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the diagonal elements of the tridiagonal matrix. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the subdiagonal elements of the tridiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ,N) */ +/* > On entry, if COMPZ = 'V', then Z contains the orthogonal */ +/* > matrix used in the reduction to tridiagonal form. */ +/* > On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ +/* > orthonormal eigenvectors of the original symmetric matrix, */ +/* > and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ +/* > of the symmetric tridiagonal matrix. */ +/* > If COMPZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If eigenvectors are desired, then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */ +/* > If COMPZ = 'V' and N > 1 then LWORK must be at least */ +/* > ( 1 + 3*N + 2*N*lg N + 4*N**2 ), */ +/* > where lg( N ) = smallest integer k such */ +/* > that 2**k >= N. */ +/* > If COMPZ = 'I' and N > 1 then LWORK must be at least */ +/* > ( 1 + 4*N + N**2 ). */ +/* > Note that for COMPZ = 'I' or 'V', then if N is less than or */ +/* > equal to the minimum divide size, usually 25, then LWORK need */ +/* > only be f2cmax(1,2*(N-1)). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */ +/* > If COMPZ = 'V' and N > 1 then LIWORK must be at least */ +/* > ( 6 + 6*N + 5*N*lg N ). */ +/* > If COMPZ = 'I' and N > 1 then LIWORK must be at least */ +/* > ( 3 + 5*N ). */ +/* > Note that for COMPZ = 'I' or 'V', then if N is less than or */ +/* > equal to the minimum divide size, usually 25, then LIWORK */ +/* > need only be 1. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: The algorithm failed to compute an eigenvalue while */ +/* > working on the submatrix lying in rows and columns */ +/* > INFO/(N+1) through mod(INFO,N+1). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA \n */ +/* > Modified by Francoise Tisseur, University of Tennessee */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ldz, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + doublereal tiny; + integer i__, j, k, m; + doublereal p; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer lwmin; + extern /* Subroutine */ int dlaed0_(integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer start, ii; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dlacpy_(char *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer finish; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *), dlasrt_(char *, integer *, doublereal *, integer *); + integer liwmin, icompz; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + doublereal orgnrm; + logical lquery; + integer smlsiz, storez, strtrw, lgn; + doublereal eps; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) { + *info = -6; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + + smlsiz = ilaenv_(&c__9, "DSTEDC", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + if (*n <= 1 || icompz == 0) { + liwmin = 1; + lwmin = 1; + } else if (*n <= smlsiz) { + liwmin = 1; + lwmin = *n - 1 << 1; + } else { + lgn = (integer) (log((doublereal) (*n)) / log(2.)); + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (icompz == 1) { +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); + liwmin = *n * 6 + 6 + *n * 5 * lgn; + } else if (icompz == 2) { +/* Computing 2nd power */ + i__1 = *n; + lwmin = (*n << 2) + 1 + i__1 * i__1; + liwmin = *n * 5 + 3; + } + } + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEDC", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (icompz != 0) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* If the following conditional clause is removed, then the routine */ +/* will use the Divide and Conquer routine to compute only the */ +/* eigenvalues, which requires (3N + 3N**2) real workspace and */ +/* (2 + 5N + 2N lg(N)) integer workspace. */ +/* Since on many architectures DSTERF is much faster than any other */ +/* algorithm for finding eigenvalues only, it is used here */ +/* as the default. If the conditional clause is removed, then */ +/* information on the size of workspace needs to be changed. */ + +/* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */ + + if (icompz == 0) { + dsterf_(n, &d__[1], &e[1], info); + goto L50; + } + +/* If N is smaller than the minimum divide size (SMLSIZ+1), then */ +/* solve the problem with another solver. */ + + if (*n <= smlsiz) { + + dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info); + + } else { + +/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */ +/* use. */ + + if (icompz == 1) { + storez = *n * *n + 1; + } else { + storez = 1; + } + + if (icompz == 2) { + dlaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz); + } + +/* Scale. */ + + orgnrm = dlanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.) { + goto L50; + } + + eps = dlamch_("Epsilon"); + + start = 1; + +/* while ( START <= N ) */ + +L10: + if (start <= *n) { + +/* Let FINISH be the position of the next subdiagonal entry */ +/* such that E( FINISH ) <= TINY or FINISH = N if no such */ +/* subdiagonal exists. The matrix identified by the elements */ +/* between START and FINISH constitutes an independent */ +/* sub-problem. */ + + finish = start; +L20: + if (finish < *n) { + tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt(( + d__2 = d__[finish + 1], abs(d__2))); + if ((d__1 = e[finish], abs(d__1)) > tiny) { + ++finish; + goto L20; + } + } + +/* (Sub) Problem determined. Compute its size and solve it. */ + + m = finish - start + 1; + if (m == 1) { + start = finish + 1; + goto L10; + } + if (m > smlsiz) { + +/* Scale. */ + + orgnrm = dlanst_("M", &m, &d__[start], &e[start]); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ + start], &m, info); + i__1 = m - 1; + i__2 = m - 1; + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ + start], &i__2, info); + + if (icompz == 1) { + strtrw = 1; + } else { + strtrw = start; + } + dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw + + start * z_dim1], ldz, &work[1], n, &work[storez], & + iwork[1], info); + if (*info != 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % + (m + 1) + start - 1; + goto L50; + } + +/* Scale back. */ + + dlascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ + start], &m, info); + + } else { + if (icompz == 1) { + +/* Since QR won't update a Z matrix which is larger than */ +/* the length of D, we must solve the sub-problem in a */ +/* workspace and then multiply back into Z. */ + + dsteqr_("I", &m, &d__[start], &e[start], &work[1], &m, & + work[m * m + 1], info); + dlacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[ + storez], n); + dgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, & + work[1], &m, &c_b17, &z__[start * z_dim1 + 1], + ldz); + } else if (icompz == 2) { + dsteqr_("I", &m, &d__[start], &e[start], &z__[start + + start * z_dim1], ldz, &work[1], info); + } else { + dsterf_(&m, &d__[start], &e[start], info); + } + if (*info != 0) { + *info = start * (*n + 1) + finish; + goto L50; + } + } + + start = finish + 1; + goto L10; + } + +/* endwhile */ + + if (icompz == 0) { + +/* Use Quick Sort */ + + dlasrt_("I", n, &d__[1], info); + + } else { + +/* Use Selection Sort to minimize swaps of eigenvectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } +/* L30: */ + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + + 1], &c__1); + } +/* L40: */ + } + } + } + +L50: + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSTEDC */ + +} /* dstedc_ */ + diff --git a/lapack-netlib/SRC/dstegr.c b/lapack-netlib/SRC/dstegr.c new file mode 100644 index 000000000..c62e9a2c5 --- /dev/null +++ b/lapack-netlib/SRC/dstegr.c @@ -0,0 +1,699 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSTEGR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSTEGR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, */ +/* ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, */ +/* LIWORK, INFO ) */ + +/* CHARACTER JOBZ, RANGE */ +/* INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER ISUPPZ( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) */ +/* DOUBLE PRECISION Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEGR computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ +/* > a well defined set of pairwise different real eigenvalues, the corresponding */ +/* > real eigenvectors are pairwise orthogonal. */ +/* > */ +/* > The spectrum may be computed either completely or partially by specifying */ +/* > either an interval (VL,VU] or a range of indices IL:IU for the desired */ +/* > eigenvalues. */ +/* > */ +/* > DSTEGR is a compatibility wrapper around the improved DSTEMR routine. */ +/* > See DSTEMR for further details. */ +/* > */ +/* > One important change is that the ABSTOL parameter no longer provides any */ +/* > benefit and hence is no longer used. */ +/* > */ +/* > Note : DSTEGR and DSTEMR work only on machines which follow */ +/* > IEEE-754 floating-point standard in their handling of infinities and */ +/* > NaNs. Normal execution may create these exceptiona values and hence */ +/* > may abort due to a floating point exception in environments which */ +/* > do not conform to the IEEE-754 standard. */ +/* > \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] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the N diagonal elements of the tridiagonal matrix */ +/* > T. On exit, D is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the (N-1) subdiagonal elements of the tridiagonal */ +/* > matrix T in elements 1 to N-1 of E. E(N) need not be set on */ +/* > input, but is used internally as workspace. */ +/* > On exit, E is overwritten. */ +/* > \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. */ +/* > 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. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ABSTOL */ +/* > \verbatim */ +/* > ABSTOL is DOUBLE PRECISION */ +/* > Unused. Was the absolute error tolerance for the */ +/* > eigenvalues/eigenvectors in previous versions. */ +/* > \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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, f2cmax(1,M) ) */ +/* > If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ +/* > contain the orthonormal eigenvectors of the matrix T */ +/* > corresponding to the selected eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > 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. */ +/* > Supplying N columns is always safe. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The i-th computed eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* > ISUPPZ( 2*i ). This is relevant in the case when the matrix */ +/* > is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal */ +/* > (and minimal) LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,18*N) */ +/* > if JOBZ = 'V', and LWORK >= f2cmax(1,12*N) if JOBZ = 'N'. */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (LIWORK) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N) */ +/* > if the eigenvectors are desired, and LIWORK >= f2cmax(1,8*N) */ +/* > if only the eigenvalues are to be computed. */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, INFO */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = 1X, internal error in DLARRE, */ +/* > if INFO = 2X, internal error in DLARRV. */ +/* > Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ +/* > the nonzero error code returned by DLARRE or */ +/* > DLARRV, respectively. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Inderjit Dhillon, IBM Almaden, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int dstegr_(char *jobz, char *range, integer *n, doublereal * + d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, + integer *iu, doublereal *abstol, integer *m, doublereal *w, + doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset; + + /* Local variables */ + extern /* Subroutine */ int dstemr_(char *, char *, integer *, doublereal + *, doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + integer *, logical *, doublereal *, integer *, integer *, integer + *, integer *); + logical tryrac; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + *info = 0; + tryrac = FALSE_; + dstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[ + z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1] + , liwork, info); + +/* End of DSTEGR */ + + return 0; +} /* dstegr_ */ + diff --git a/lapack-netlib/SRC/dstein.c b/lapack-netlib/SRC/dstein.c new file mode 100644 index 000000000..42f09b6fc --- /dev/null +++ b/lapack-netlib/SRC/dstein.c @@ -0,0 +1,899 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSTEIN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSTEIN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, */ +/* IWORK, IFAIL, INFO ) */ + +/* INTEGER INFO, LDZ, M, N */ +/* INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), */ +/* $ IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEIN computes the eigenvectors of a real symmetric tridiagonal */ +/* > matrix T corresponding to specified eigenvalues, using inverse */ +/* > iteration. */ +/* > */ +/* > The maximum number of iterations allowed for each eigenvector is */ +/* > specified by an internal parameter MAXITS (currently set to 5). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the tridiagonal matrix */ +/* > T, in elements 1 to N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of eigenvectors to be found. 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > The first M elements of W contain the eigenvalues for */ +/* > which eigenvectors are to be computed. The eigenvalues */ +/* > should be grouped by split-off block and ordered from */ +/* > smallest to largest within the block. ( The output array */ +/* > W from DSTEBZ with ORDER = 'B' is expected here. ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IBLOCK */ +/* > \verbatim */ +/* > IBLOCK is INTEGER array, dimension (N) */ +/* > The submatrix indices associated with the corresponding */ +/* > eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */ +/* > the first submatrix from the top, =2 if W(i) belongs to */ +/* > the second submatrix, etc. ( The output array IBLOCK */ +/* > from DSTEBZ is expected here. ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into submatrices. */ +/* > The first submatrix consists of rows/columns 1 to */ +/* > ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ +/* > through ISPLIT( 2 ), etc. */ +/* > ( The output array ISPLIT from DSTEBZ is expected here. ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, M) */ +/* > The computed eigenvectors. The eigenvector associated */ +/* > with the eigenvalue W(i) is stored in the i-th column of */ +/* > Z. Any vector which fails to converge is set to its current */ +/* > iterate after MAXITS iterations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (5*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAIL */ +/* > \verbatim */ +/* > IFAIL is INTEGER array, dimension (M) */ +/* > On normal exit, all elements of IFAIL are zero. */ +/* > If one or more eigenvectors fail to converge after */ +/* > MAXITS iterations, then their indices are stored in */ +/* > array IFAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, then i eigenvectors failed to converge */ +/* > in MAXITS iterations. Their indices are stored in */ +/* > array IFAIL. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > MAXITS INTEGER, default = 5 */ +/* > The maximum number of iterations performed. */ +/* > */ +/* > EXTRA INTEGER, default = 2 */ +/* > The number of iterations performed after norm growth */ +/* > criterion is satisfied, should be at least 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dstein_(integer *n, doublereal *d__, doublereal *e, + integer *m, doublereal *w, integer *iblock, integer *isplit, + doublereal *z__, integer *ldz, doublereal *work, integer *iwork, + integer *ifail, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + integer jblk, nblk; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + integer jmax; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + integer iseed[4], gpind, iinfo; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer b1; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + integer j1; + doublereal ortol; + integer indrv1, indrv2, indrv3, indrv4, indrv5, bn; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int dlagtf_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer * + , integer *); + doublereal xj; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlagts_( + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + integer nrmchk; + extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *, + doublereal *); + integer blksiz; + doublereal onenrm, dtpcrt, pertol, scl, eps, sep, nrm, tol; + integer its; + doublereal xjm, ztr, eps1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + --iblock; + --isplit; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + *info = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + + if (*n < 0) { + *info = -1; + } else if (*m < 0 || *m > *n) { + *info = -4; + } else if (*ldz < f2cmax(1,*n)) { + *info = -9; + } else { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + if (iblock[j] < iblock[j - 1]) { + *info = -6; + goto L30; + } + if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { + *info = -5; + goto L30; + } +/* L20: */ + } +L30: + ; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEIN", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } else if (*n == 1) { + z__[z_dim1 + 1] = 1.; + return 0; + } + +/* Get machine constants. */ + + eps = dlamch_("Precision"); + +/* Initialize seed for random number generator DLARNV. */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__ - 1] = 1; +/* L40: */ + } + +/* Initialize pointers. */ + + indrv1 = 0; + indrv2 = indrv1 + *n; + indrv3 = indrv2 + *n; + indrv4 = indrv3 + *n; + indrv5 = indrv4 + *n; + +/* Compute eigenvectors of matrix blocks. */ + + j1 = 1; + i__1 = iblock[*m]; + for (nblk = 1; nblk <= i__1; ++nblk) { + +/* Find starting and ending indices of block nblk. */ + + if (nblk == 1) { + b1 = 1; + } else { + b1 = isplit[nblk - 1] + 1; + } + bn = isplit[nblk]; + blksiz = bn - b1 + 1; + if (blksiz == 1) { + goto L60; + } + gpind = j1; + +/* Compute reorthogonalization criterion and stopping criterion. */ + + onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 = e[b1], abs(d__2)); +/* Computing MAX */ + d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1], + abs(d__2)); + onenrm = f2cmax(d__3,d__4); + i__2 = bn - 1; + for (i__ = b1 + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ + i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3)); + onenrm = f2cmax(d__4,d__5); +/* L50: */ + } + ortol = onenrm * .001; + + dtpcrt = sqrt(.1 / blksiz); + +/* Loop through eigenvalues of block nblk. */ + +L60: + jblk = 0; + i__2 = *m; + for (j = j1; j <= i__2; ++j) { + if (iblock[j] != nblk) { + j1 = j; + goto L160; + } + ++jblk; + xj = w[j]; + +/* Skip all the work if the block size is one. */ + + if (blksiz == 1) { + work[indrv1 + 1] = 1.; + goto L120; + } + +/* If eigenvalues j and j-1 are too close, add a relatively */ +/* small perturbation. */ + + if (jblk > 1) { + eps1 = (d__1 = eps * xj, abs(d__1)); + pertol = eps1 * 10.; + sep = xj - xjm; + if (sep < pertol) { + xj = xjm + pertol; + } + } + + its = 0; + nrmchk = 0; + +/* Get random starting vector. */ + + dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]); + +/* Copy the matrix T so it won't be destroyed in factorization. */ + + dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1); + i__3 = blksiz - 1; + dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1); + i__3 = blksiz - 1; + dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1); + +/* Compute LU factors with partial pivoting ( PT = LU ) */ + + tol = 0.; + dlagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[ + indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo); + +/* Update iteration count. */ + +L70: + ++its; + if (its > 5) { + goto L100; + } + +/* Normalize and scale the righthand side vector Pb. */ + + jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); +/* Computing MAX */ + d__3 = eps, d__4 = (d__1 = work[indrv4 + blksiz], abs(d__1)); + scl = blksiz * onenrm * f2cmax(d__3,d__4) / (d__2 = work[indrv1 + + jmax], abs(d__2)); + dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); + +/* Solve the system LU = Pb. */ + + dlagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], & + work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[ + indrv1 + 1], &tol, &iinfo); + +/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */ +/* close enough. */ + + if (jblk == 1) { + goto L90; + } + if ((d__1 = xj - xjm, abs(d__1)) > ortol) { + gpind = j; + } + if (gpind != j) { + i__3 = j - 1; + for (i__ = gpind; i__ <= i__3; ++i__) { + ztr = -ddot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 + + i__ * z_dim1], &c__1); + daxpy_(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, & + work[indrv1 + 1], &c__1); +/* L80: */ + } + } + +/* Check the infinity norm of the iterate. */ + +L90: + jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); + nrm = (d__1 = work[indrv1 + jmax], abs(d__1)); + +/* Continue for additional iterations after norm reaches */ +/* stopping criterion. */ + + if (nrm < dtpcrt) { + goto L70; + } + ++nrmchk; + if (nrmchk < 3) { + goto L70; + } + + goto L110; + +/* If stopping criterion was not satisfied, update info and */ +/* store eigenvector number in array ifail. */ + +L100: + ++(*info); + ifail[*info] = j; + +/* Accept iterate as jth eigenvector. */ + +L110: + scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1); + jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); + if (work[indrv1 + jmax] < 0.) { + scl = -scl; + } + dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); +L120: + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[i__ + j * z_dim1] = 0.; +/* L130: */ + } + i__3 = blksiz; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__]; +/* L140: */ + } + +/* Save the shift to check eigenvalue spacing at next */ +/* iteration. */ + + xjm = xj; + +/* L150: */ + } +L160: + ; + } + + return 0; + +/* End of DSTEIN */ + +} /* dstein_ */ + diff --git a/lapack-netlib/SRC/dstemr.c b/lapack-netlib/SRC/dstemr.c new file mode 100644 index 000000000..688c48b5a --- /dev/null +++ b/lapack-netlib/SRC/dstemr.c @@ -0,0 +1,1209 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSTEMR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSTEMR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, */ +/* M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, */ +/* IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, RANGE */ +/* LOGICAL TRYRAC */ +/* INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N */ +/* DOUBLE PRECISION VL, VU */ +/* INTEGER ISUPPZ( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) */ +/* DOUBLE PRECISION Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEMR computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ +/* > a well defined set of pairwise different real eigenvalues, the corresponding */ +/* > real eigenvectors are pairwise orthogonal. */ +/* > */ +/* > The spectrum may be computed either completely or partially by specifying */ +/* > either an interval (VL,VU] or a range of indices IL:IU for the desired */ +/* > eigenvalues. */ +/* > */ +/* > Depending on the number of desired eigenvalues, these are computed either */ +/* > by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */ +/* > computed by the use of various suitable L D L^T factorizations near clusters */ +/* > of close eigenvalues (referred to as RRRs, Relatively Robust */ +/* > Representations). An informal sketch of the algorithm follows. */ +/* > */ +/* > For each unreduced block (submatrix) of T, */ +/* > (a) Compute T - sigma I = L D L^T, so that L and D */ +/* > define all the wanted eigenvalues to high relative accuracy. */ +/* > This means that small relative changes in the entries of D and L */ +/* > cause only small relative changes in the eigenvalues and */ +/* > eigenvectors. The standard (unfactored) representation of the */ +/* > tridiagonal matrix T does not have this property in general. */ +/* > (b) Compute the eigenvalues to suitable accuracy. */ +/* > If the eigenvectors are desired, the algorithm attains full */ +/* > accuracy of the computed eigenvalues only right before */ +/* > the corresponding vectors have to be computed, see steps c) and d). */ +/* > (c) For each cluster of close eigenvalues, select a new */ +/* > shift close to the cluster, find a new factorization, and refine */ +/* > the shifted eigenvalues to suitable accuracy. */ +/* > (d) For each eigenvalue with a large enough relative separation compute */ +/* > the corresponding eigenvector by forming a rank revealing twisted */ +/* > factorization. Go back to (c) for any clusters that remain. */ +/* > */ +/* > For more details, see: */ +/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ +/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ +/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ +/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ +/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ +/* > 2004. Also LAPACK Working Note 154. */ +/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ +/* > tridiagonal eigenvalue/eigenvector problem", */ +/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ +/* > UC Berkeley, May 1997. */ +/* > */ +/* > Further Details */ +/* > 1.DSTEMR works only on machines which follow IEEE-754 */ +/* > floating-point standard in their handling of infinities and NaNs. */ +/* > This permits the use of efficient inner loops avoiding a check for */ +/* > zero divisors. */ +/* > \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] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the N diagonal elements of the tridiagonal matrix */ +/* > T. On exit, D is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the (N-1) subdiagonal elements of the tridiagonal */ +/* > matrix T in elements 1 to N-1 of E. E(N) need not be set on */ +/* > input, but is used internally as workspace. */ +/* > On exit, E is overwritten. */ +/* > \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. */ +/* > 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. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, f2cmax(1,M) ) */ +/* > If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ +/* > contain the orthonormal eigenvectors of the matrix T */ +/* > corresponding to the selected eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > 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 can be computed with a workspace */ +/* > query by setting NZC = -1, see below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NZC */ +/* > \verbatim */ +/* > NZC is INTEGER */ +/* > The number of eigenvectors to be held in the array Z. */ +/* > If RANGE = 'A', then NZC >= f2cmax(1,N). */ +/* > If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */ +/* > If RANGE = 'I', then NZC >= IU-IL+1. */ +/* > If NZC = -1, then a workspace query is assumed; the */ +/* > routine calculates the number of columns of the array Z that */ +/* > are needed to hold the eigenvectors. */ +/* > This value is returned as the first entry of the Z array, and */ +/* > no error message related to NZC is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The i-th computed eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* > ISUPPZ( 2*i ). This is relevant in the case when the matrix */ +/* > is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] TRYRAC */ +/* > \verbatim */ +/* > TRYRAC is LOGICAL */ +/* > If TRYRAC = .TRUE., indicates that the code should check whether */ +/* > the tridiagonal matrix defines its eigenvalues to high relative */ +/* > accuracy. If so, the code uses relative-accuracy preserving */ +/* > algorithms that might be (a bit) slower depending on the matrix. */ +/* > If the matrix does not define its eigenvalues to high relative */ +/* > accuracy, the code can uses possibly faster algorithms. */ +/* > If TRYRAC = .FALSE., the code is not required to guarantee */ +/* > relatively accurate eigenvalues and can use the fastest possible */ +/* > techniques. */ +/* > On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */ +/* > does not define its eigenvalues to high relative accuracy. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal */ +/* > (and minimal) LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,18*N) */ +/* > if JOBZ = 'V', and LWORK >= f2cmax(1,12*N) if JOBZ = 'N'. */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (LIWORK) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N) */ +/* > if the eigenvectors are desired, and LIWORK >= f2cmax(1,8*N) */ +/* > if only the eigenvalues are to be computed. */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, INFO */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = 1X, internal error in DLARRE, */ +/* > if INFO = 2X, internal error in DLARRV. */ +/* > Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ +/* > the nonzero error code returned by DLARRE or */ +/* > DLARRV, respectively. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal * + d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, + integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz, + integer *nzc, integer *isuppz, logical *tryrac, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer indd, iend, jblk, wend; + doublereal rmin, rmax; + integer itmp; + doublereal tnrm; + extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); + integer inde2, itmp2; + doublereal rtol1, rtol2; + integer i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal scale; + integer indgp; + extern logical lsame_(char *, char *); + integer iinfo, iindw, ilast; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer lwmin; + logical wantz; + doublereal r1, r2; + extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + integer jj; + doublereal cs; + integer in; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer ibegin, iindbl; + doublereal sn, wl; + logical valeig; + extern /* Subroutine */ int dlarrc_(char *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, integer *, integer *), dlarre_(char *, + integer *, doublereal *, doublereal *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, integer *); + integer wbegin; + doublereal safmin, wu; + extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *), xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer inderr, iindwk, indgrs, offset; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dlarrr_(integer *, doublereal *, doublereal *, + integer *), dlarrv_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dlasrt_(char *, integer *, doublereal *, + integer *); + doublereal thresh; + integer iinspl, ifirst, indwrk, liwmin, nzcmin; + doublereal pivmin; + integer nsplit; + doublereal smlnum; + logical lquery, zquery; + integer iil, iiu; + doublereal eps, tmp; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; + zquery = *nzc == -1; +/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */ +/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */ +/* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */ + if (wantz) { + lwmin = *n * 18; + liwmin = *n * 10; + } else { +/* need less workspace if only the eigenvalues are wanted */ + lwmin = *n * 12; + liwmin = *n << 3; + } + wl = 0.; + wu = 0.; + iil = 0; + iiu = 0; + nsplit = 0; + if (valeig) { +/* We do not reference VL, VU in the cases RANGE = 'I','A' */ +/* The interval (WL, WU] contains all the wanted eigenvalues. */ +/* It is either given by the user or computed in DLARRE. */ + wl = *vl; + wu = *vu; + } else if (indeig) { +/* We do not reference IL, IU in the cases RANGE = 'V','A' */ + iil = *il; + iiu = *iu; + } + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (valeig && *n > 0 && wu <= wl) { + *info = -7; + } else if (indeig && (iil < 1 || iil > *n)) { + *info = -8; + } else if (indeig && (iiu < iil || iiu > *n)) { + *info = -9; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -13; + } else if (*lwork < lwmin && ! lquery) { + *info = -17; + } else if (*liwork < liwmin && ! lquery) { + *info = -19; + } + +/* 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); + + if (*info == 0) { + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (wantz && alleig) { + nzcmin = *n; + } else if (wantz && valeig) { + dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & + itmp2, info); + } else if (wantz && indeig) { + nzcmin = iiu - iil + 1; + } else { +/* WANTZ .EQ. FALSE. */ + nzcmin = 0; + } + if (zquery && *info == 0) { + z__[z_dim1 + 1] = (doublereal) nzcmin; + } else if (*nzc < nzcmin && ! zquery) { + *info = -14; + } + } + if (*info != 0) { + + i__1 = -(*info); + xerbla_("DSTEMR", &i__1, (ftnlen)6); + + return 0; + } else if (lquery || zquery) { + return 0; + } + +/* Handle N = 0, 1, and 2 cases immediately */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = d__[1]; + } else { + if (wl < d__[1] && wu >= d__[1]) { + *m = 1; + w[1] = d__[1]; + } + } + if (wantz && ! zquery) { + z__[z_dim1 + 1] = 1.; + isuppz[1] = 1; + isuppz[2] = 1; + } + return 0; + } + + if (*n == 2) { + if (! wantz) { + dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2); + } else if (wantz && ! zquery) { + dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn); + } + if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) { + ++(*m); + w[*m] = r2; + if (wantz && ! zquery) { + z__[*m * z_dim1 + 1] = -sn; + z__[*m * z_dim1 + 2] = cs; +/* Note: At most one of SN and CS can be zero. */ + if (sn != 0.) { + if (cs != 0.) { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 2; + } else { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 1; + } + } else { + isuppz[(*m << 1) - 1] = 2; + isuppz[*m * 2] = 2; + } + } + } + if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) { + ++(*m); + w[*m] = r1; + if (wantz && ! zquery) { + z__[*m * z_dim1 + 1] = cs; + z__[*m * z_dim1 + 2] = sn; +/* Note: At most one of SN and CS can be zero. */ + if (sn != 0.) { + if (cs != 0.) { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 2; + } else { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 1; + } + } else { + isuppz[(*m << 1) - 1] = 2; + isuppz[*m * 2] = 2; + } + } + } + } else { +/* Continue with general N */ + indgrs = 1; + inderr = (*n << 1) + 1; + indgp = *n * 3 + 1; + indd = (*n << 2) + 1; + inde2 = *n * 5 + 1; + indwrk = *n * 6 + 1; + + iinspl = 1; + iindbl = *n + 1; + iindw = (*n << 1) + 1; + iindwk = *n * 3 + 1; + +/* Scale matrix to allowable range, if necessary. */ +/* The allowable range is related to the PIVMIN parameter; see the */ +/* comments in DLARRD. The preference for scaling small values */ +/* up is heuristic; we expect users' matrices not to be close to the */ +/* RMAX threshold. */ + + scale = 1.; + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + scale = rmin / tnrm; + } else if (tnrm > rmax) { + scale = rmax / tnrm; + } + if (scale != 1.) { + dscal_(n, &scale, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &scale, &e[1], &c__1); + tnrm *= scale; + if (valeig) { +/* If eigenvalues in interval have to be found, */ +/* scale (WL, WU] accordingly */ + wl *= scale; + wu *= scale; + } + } + +/* Compute the desired eigenvalues of the tridiagonal after splitting */ +/* into smaller subblocks if the corresponding off-diagonal elements */ +/* are small */ +/* THRESH is the splitting parameter for DLARRE */ +/* A negative THRESH forces the old splitting criterion based on the */ +/* size of the off-diagonal. A positive THRESH switches to splitting */ +/* which preserves relative accuracy. */ + + if (*tryrac) { +/* Test whether the matrix warrants the more expensive relative approach. */ + dlarrr_(n, &d__[1], &e[1], &iinfo); + } else { +/* The user does not care about relative accurately eigenvalues */ + iinfo = -1; + } +/* Set the splitting criterion */ + if (iinfo == 0) { + thresh = eps; + } else { + thresh = -eps; +/* relative accuracy is desired but T does not guarantee it */ + *tryrac = FALSE_; + } + + if (*tryrac) { +/* Copy original diagonal, needed to guarantee relative accuracy */ + dcopy_(n, &d__[1], &c__1, &work[indd], &c__1); + } +/* Store the squares of the offdiagonal values of T */ + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing 2nd power */ + d__1 = e[j]; + work[inde2 + j - 1] = d__1 * d__1; +/* L5: */ + } +/* Set the tolerance parameters for bisection */ + if (! wantz) { +/* DLARRE computes the eigenvalues to full precision. */ + rtol1 = eps * 4.; + rtol2 = eps * 4.; + } else { +/* DLARRE computes the eigenvalues to less than full precision. */ +/* DLARRV will refine the eigenvalue approximations, and we can */ +/* need less accurate initial bisection in DLARRE. */ +/* Note: these settings do only affect the subset case and DLARRE */ + rtol1 = sqrt(eps); +/* Computing MAX */ + d__1 = sqrt(eps) * .005, d__2 = eps * 4.; + rtol2 = f2cmax(d__1,d__2); + } + dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], + &rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], & + work[inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], & + work[indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo); + if (iinfo != 0) { + *info = abs(iinfo) + 10; + return 0; + } +/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */ +/* part of the spectrum. All desired eigenvalues are contained in */ +/* (WL,WU] */ + if (wantz) { + +/* Compute the desired eigenvectors corresponding to the computed */ +/* eigenvalues */ + + dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & + c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], & + work[indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], + &z__[z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[ + iindwk], &iinfo); + if (iinfo != 0) { + *info = abs(iinfo) + 20; + return 0; + } + } else { +/* DLARRE computes eigenvalues of the (shifted) root representation */ +/* DLARRV returns the eigenvalues of the unshifted matrix. */ +/* However, if the eigenvectors are not desired by the user, we need */ +/* to apply the corresponding shifts from DLARRE to obtain the */ +/* eigenvalues of the original matrix. */ + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + itmp = iwork[iindbl + j - 1]; + w[j] += e[iwork[iinspl + itmp - 1]]; +/* L20: */ + } + } + + if (*tryrac) { +/* Refine computed eigenvalues so that they are relatively accurate */ +/* with respect to the original matrix T. */ + ibegin = 1; + wbegin = 1; + i__1 = iwork[iindbl + *m - 1]; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = iwork[iinspl + jblk - 1]; + in = iend - ibegin + 1; + wend = wbegin - 1; +/* check if any eigenvalues have to be refined in this block */ +L36: + if (wend < *m) { + if (iwork[iindbl + wend] == jblk) { + ++wend; + goto L36; + } + } + if (wend < wbegin) { + ibegin = iend + 1; + goto L39; + } + offset = iwork[iindw + wbegin - 1] - 1; + ifirst = iwork[iindw + wbegin - 1]; + ilast = iwork[iindw + wend - 1]; + rtol2 = eps * 4.; + dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - + 1], &ifirst, &ilast, &rtol2, &offset, &w[wbegin], & + work[inderr + wbegin - 1], &work[indwrk], &iwork[ + iindwk], &pivmin, &tnrm, &iinfo); + ibegin = iend + 1; + wbegin = wend + 1; +L39: + ; + } + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (scale != 1.) { + d__1 = 1. / scale; + dscal_(m, &d__1, &w[1], &c__1); + } + } + +/* If eigenvalues are not in increasing order, then sort them, */ +/* possibly along with eigenvectors. */ + + if (nsplit > 1 || *n == 2) { + if (! wantz) { + dlasrt_("I", m, &w[1], &iinfo); + if (iinfo != 0) { + *info = 3; + return 0; + } + } else { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp) { + i__ = jj; + tmp = w[jj]; + } +/* L50: */ + } + if (i__ != 0) { + w[i__] = w[j]; + w[j] = tmp; + if (wantz) { + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * + z_dim1 + 1], &c__1); + itmp = isuppz[(i__ << 1) - 1]; + isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1]; + isuppz[(j << 1) - 1] = itmp; + itmp = isuppz[i__ * 2]; + isuppz[i__ * 2] = isuppz[j * 2]; + isuppz[j * 2] = itmp; + } + } +/* L60: */ + } + } + } + + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSTEMR */ + +} /* dstemr_ */ + diff --git a/lapack-netlib/SRC/dsteqr.c b/lapack-netlib/SRC/dsteqr.c new file mode 100644 index 000000000..9bf3f3a4a --- /dev/null +++ b/lapack-netlib/SRC/dsteqr.c @@ -0,0 +1,1052 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSTEQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSTEQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) */ + +/* CHARACTER COMPZ */ +/* INTEGER INFO, LDZ, N */ +/* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */ +/* > symmetric tridiagonal matrix using the implicit QL or QR method. */ +/* > The eigenvectors of a full or band symmetric matrix can also be found */ +/* > if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */ +/* > tridiagonal form. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only. */ +/* > = 'V': Compute eigenvalues and eigenvectors of the original */ +/* > symmetric matrix. On entry, Z must contain the */ +/* > orthogonal matrix used to reduce the original matrix */ +/* > to tridiagonal form. */ +/* > = 'I': Compute eigenvalues and eigenvectors of the */ +/* > tridiagonal matrix. Z is initialized to the identity */ +/* > matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the diagonal elements of the tridiagonal matrix. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', then Z contains the orthogonal */ +/* > matrix used in the reduction to tridiagonal form. */ +/* > On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ +/* > orthonormal eigenvectors of the original symmetric matrix, */ +/* > and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ +/* > of the symmetric tridiagonal matrix. */ +/* > If COMPZ = '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 */ +/* > eigenvectors are desired, then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (f2cmax(1,2*N-2)) */ +/* > If COMPZ = 'N', then WORK 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: the algorithm has failed to find all the eigenvalues in */ +/* > a total of 30*N iterations; if INFO = i, then i */ +/* > elements of E have not converged to zero; on exit, D */ +/* > and E contain the elements of a symmetric tridiagonal */ +/* > matrix which is orthogonally similar to the original */ +/* > matrix. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ldz, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer lend, jtot; + extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); + doublereal b, c__, f, g; + integer i__, j, k, l, m; + doublereal p, r__, s; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *); + doublereal anorm; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer l1; + extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + integer lendm1, lendp1; + extern doublereal dlapy2_(doublereal *, doublereal *); + integer ii; + extern doublereal dlamch_(char *); + integer mm, iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dlaset_(char *, integer *, integer + *, doublereal *, doublereal *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + doublereal safmax; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *); + integer lendsv; + doublereal ssfmin; + integer nmaxit, icompz; + doublereal ssfmax; + integer lm1, mm1, nm1; + doublereal rt1, rt2, eps; + integer lsv; + doublereal tst, eps2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEQR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (icompz == 2) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Determine the unit roundoff and over/underflow thresholds. */ + + eps = dlamch_("E"); +/* Computing 2nd power */ + d__1 = eps; + eps2 = d__1 * d__1; + safmin = dlamch_("S"); + safmax = 1. / safmin; + ssfmax = sqrt(safmax) / 3.; + ssfmin = sqrt(safmin) / eps2; + +/* Compute the eigenvalues and eigenvectors of the tridiagonal */ +/* matrix. */ + + if (icompz == 2) { + dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz); + } + + nmaxit = *n * 30; + jtot = 0; + +/* Determine where the matrix splits and choose QL or QR iteration */ +/* for each block, according to whether top or bottom diagonal */ +/* element is smaller. */ + + l1 = 1; + nm1 = *n - 1; + +L10: + if (l1 > *n) { + goto L160; + } + if (l1 > 1) { + e[l1 - 1] = 0.; + } + if (l1 <= nm1) { + i__1 = nm1; + for (m = l1; m <= i__1; ++m) { + tst = (d__1 = e[m], abs(d__1)); + if (tst == 0.) { + goto L30; + } + if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } +/* L20: */ + } + } + m = *n; + +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + +/* Scale submatrix in rows and columns L to LEND */ + + i__1 = lend - l + 1; + anorm = dlanst_("M", &i__1, &d__[l], &e[l]); + iscale = 0; + if (anorm == 0.) { + goto L10; + } + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info); + } + +/* Choose between QL and QR iteration */ + + if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { + lend = lsv; + l = lendsv; + } + + if (lend > l) { + +/* QL Iteration */ + +/* Look for small subdiagonal element. */ + +L40: + if (l != lend) { + lendm1 = lend - 1; + i__1 = lendm1; + for (m = l; m <= i__1; ++m) { +/* Computing 2nd power */ + d__2 = (d__1 = e[m], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + + 1], abs(d__2)) + safmin) { + goto L60; + } +/* L50: */ + } + } + + m = lend; + +L60: + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L80; + } + +/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ +/* to compute its eigensystem. */ + + if (m == l + 1) { + if (icompz > 0) { + dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); + work[l] = c__; + work[*n - 1 + l] = s; + dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & + z__[l * z_dim1 + 1], ldz); + } else { + dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); + } + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L40; + } + goto L140; + } + + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + +/* Form shift. */ + + g = (d__[l + 1] - p) / (e[l] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); + + s = 1.; + c__ = 1.; + p = 0.; + +/* Inner loop */ + + mm1 = m - 1; + i__1 = l; + for (i__ = mm1; i__ >= i__1; --i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m - 1) { + e[i__ + 1] = r__; + } + g = d__[i__ + 1] - p; + r__ = (d__[i__] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__ + 1] = g + p; + g = c__ * r__ - b; + +/* If eigenvectors are desired, then save rotations. */ + + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = -s; + } + +/* L70: */ + } + +/* If eigenvectors are desired, then apply saved rotations. */ + + if (icompz > 0) { + mm = m - l + 1; + dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l + * z_dim1 + 1], ldz); + } + + d__[l] -= p; + e[l] = g; + goto L40; + +/* Eigenvalue found. */ + +L80: + d__[l] = p; + + ++l; + if (l <= lend) { + goto L40; + } + goto L140; + + } else { + +/* QR Iteration */ + +/* Look for small superdiagonal element. */ + +L90: + if (l != lend) { + lendp1 = lend + 1; + i__1 = lendp1; + for (m = l; m >= i__1; --m) { +/* Computing 2nd power */ + d__2 = (d__1 = e[m - 1], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + - 1], abs(d__2)) + safmin) { + goto L110; + } +/* L100: */ + } + } + + m = lend; + +L110: + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L130; + } + +/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ +/* to compute its eigensystem. */ + + if (m == l - 1) { + if (icompz > 0) { + dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) + ; + work[m] = c__; + work[*n - 1 + m] = s; + dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & + z__[(l - 1) * z_dim1 + 1], ldz); + } else { + dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); + } + d__[l - 1] = rt1; + d__[l] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L90; + } + goto L140; + } + + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + +/* Form shift. */ + + g = (d__[l - 1] - p) / (e[l - 1] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); + + s = 1.; + c__ = 1.; + p = 0.; + +/* Inner loop */ + + lm1 = l - 1; + i__1 = lm1; + for (i__ = m; i__ <= i__1; ++i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m) { + e[i__ - 1] = r__; + } + g = d__[i__] - p; + r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__] = g + p; + g = c__ * r__ - b; + +/* If eigenvectors are desired, then save rotations. */ + + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = s; + } + +/* L120: */ + } + +/* If eigenvectors are desired, then apply saved rotations. */ + + if (icompz > 0) { + mm = l - m + 1; + dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m + * z_dim1 + 1], ldz); + } + + d__[l] -= p; + e[lm1] = g; + goto L90; + +/* Eigenvalue found. */ + +L130: + d__[l] = p; + + --l; + if (l >= lend) { + goto L90; + } + goto L140; + + } + +/* Undo scaling if necessary */ + +L140: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + i__1 = lendsv - lsv; + dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, + info); + } else if (iscale == 2) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + i__1 = lendsv - lsv; + dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, + info); + } + +/* Check for no convergence to an eigenvalue after a total */ +/* of N*MAXIT iterations. */ + + if (jtot < nmaxit) { + goto L10; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } +/* L150: */ + } + goto L190; + +/* Order eigenvalues and eigenvectors. */ + +L160: + if (icompz == 0) { + +/* Use Quick Sort */ + + dlasrt_("I", n, &d__[1], info); + + } else { + +/* Use Selection Sort to minimize swaps of eigenvectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } +/* L170: */ + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], + &c__1); + } +/* L180: */ + } + } + +L190: + return 0; + +/* End of DSTEQR */ + +} /* dsteqr_ */ + diff --git a/lapack-netlib/SRC/dsterf.c b/lapack-netlib/SRC/dsterf.c new file mode 100644 index 000000000..916d09b4f --- /dev/null +++ b/lapack-netlib/SRC/dsterf.c @@ -0,0 +1,882 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSTERF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSTERF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTERF( N, D, E, INFO ) */ + +/* INTEGER INFO, N */ +/* DOUBLE PRECISION D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTERF computes all eigenvalues of a symmetric tridiagonal matrix */ +/* > using the Pal-Walker-Kahan variant of the QL or QR algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: the algorithm failed to find all of the eigenvalues in */ +/* > a total of 30*N iterations; if INFO = i, then i */ +/* > elements of E have not converged 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 auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e, + integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3; + + /* Local variables */ + doublereal oldc; + integer lend; + doublereal rmax; + integer jtot; + extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); + doublereal c__; + integer i__, l, m; + doublereal p, gamma, r__, s, alpha, sigma, anorm; + integer l1; + extern doublereal dlapy2_(doublereal *, doublereal *); + doublereal bb; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + doublereal oldgam, safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal safmax; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *); + integer lendsv; + doublereal ssfmin; + integer nmaxit; + doublereal ssfmax, rt1, rt2, eps, rte; + integer lsv; + doublereal eps2; + + +/* -- 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 */ + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("DSTERF", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 1) { + return 0; + } + +/* Determine the unit roundoff for this environment. */ + + eps = dlamch_("E"); +/* Computing 2nd power */ + d__1 = eps; + eps2 = d__1 * d__1; + safmin = dlamch_("S"); + safmax = 1. / safmin; + ssfmax = sqrt(safmax) / 3.; + ssfmin = sqrt(safmin) / eps2; + rmax = dlamch_("O"); + +/* Compute the eigenvalues of the tridiagonal matrix. */ + + nmaxit = *n * 30; + sigma = 0.; + jtot = 0; + +/* Determine where the matrix splits and choose QL or QR iteration */ +/* for each block, according to whether top or bottom diagonal */ +/* element is smaller. */ + + l1 = 1; + +L10: + if (l1 > *n) { + goto L170; + } + if (l1 > 1) { + e[l1 - 1] = 0.; + } + i__1 = *n - 1; + for (m = l1; m <= i__1; ++m) { + if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) * + sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } +/* L20: */ + } + m = *n; + +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + +/* Scale submatrix in rows and columns L to LEND */ + + i__1 = lend - l + 1; + anorm = dlanst_("M", &i__1, &d__[l], &e[l]); + iscale = 0; + if (anorm == 0.) { + goto L10; + } + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info); + } + + i__1 = lend - 1; + for (i__ = l; i__ <= i__1; ++i__) { +/* Computing 2nd power */ + d__1 = e[i__]; + e[i__] = d__1 * d__1; +/* L40: */ + } + +/* Choose between QL and QR iteration */ + + if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { + lend = lsv; + l = lendsv; + } + + if (lend >= l) { + +/* QL Iteration */ + +/* Look for small subdiagonal element. */ + +L50: + if (l != lend) { + i__1 = lend - 1; + for (m = l; m <= i__1; ++m) { + if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + + 1], abs(d__1))) { + goto L70; + } +/* L60: */ + } + } + m = lend; + +L70: + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L90; + } + +/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ +/* eigenvalues. */ + + if (m == l + 1) { + rte = sqrt(e[l]); + dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L50; + } + goto L150; + } + + if (jtot == nmaxit) { + goto L150; + } + ++jtot; + +/* Form shift. */ + + rte = sqrt(e[l]); + sigma = (d__[l + 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b33); + sigma = p - rte / (sigma + d_sign(&r__, &sigma)); + + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; + +/* Inner loop */ + + i__1 = l; + for (i__ = m - 1; i__ >= i__1; --i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m - 1) { + e[i__ + 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__ + 1] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } +/* L80: */ + } + + e[l] = s * p; + d__[l] = sigma + gamma; + goto L50; + +/* Eigenvalue found. */ + +L90: + d__[l] = p; + + ++l; + if (l <= lend) { + goto L50; + } + goto L150; + + } else { + +/* QR Iteration */ + +/* Look for small superdiagonal element. */ + +L100: + i__1 = lend + 1; + for (m = l; m >= i__1; --m) { + if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + - 1], abs(d__1))) { + goto L120; + } +/* L110: */ + } + m = lend; + +L120: + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L140; + } + +/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ +/* eigenvalues. */ + + if (m == l - 1) { + rte = sqrt(e[l - 1]); + dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); + d__[l] = rt1; + d__[l - 1] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L100; + } + goto L150; + } + + if (jtot == nmaxit) { + goto L150; + } + ++jtot; + +/* Form shift. */ + + rte = sqrt(e[l - 1]); + sigma = (d__[l - 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b33); + sigma = p - rte / (sigma + d_sign(&r__, &sigma)); + + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; + +/* Inner loop */ + + i__1 = l - 1; + for (i__ = m; i__ <= i__1; ++i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m) { + e[i__ - 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__ + 1]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } +/* L130: */ + } + + e[l - 1] = s * p; + d__[l] = sigma + gamma; + goto L100; + +/* Eigenvalue found. */ + +L140: + d__[l] = p; + + --l; + if (l >= lend) { + goto L100; + } + goto L150; + + } + +/* Undo scaling if necessary */ + +L150: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + } + if (iscale == 2) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + } + +/* Check for no convergence to an eigenvalue after a total */ +/* of N*MAXIT iterations. */ + + if (jtot < nmaxit) { + goto L10; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } +/* L160: */ + } + goto L180; + +/* Sort eigenvalues in increasing order. */ + +L170: + dlasrt_("I", n, &d__[1], info); + +L180: + return 0; + +/* End of DSTERF */ + +} /* dsterf_ */ + diff --git a/lapack-netlib/SRC/dstev.c b/lapack-netlib/SRC/dstev.c new file mode 100644 index 000000000..1991b4848 --- /dev/null +++ b/lapack-netlib/SRC/dstev.c @@ -0,0 +1,639 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSTEV 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 DSTEV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) */ + +/* CHARACTER JOBZ */ +/* INTEGER INFO, LDZ, N */ +/* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEV computes all eigenvalues and, optionally, eigenvectors of a */ +/* > real symmetric tridiagonal matrix A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A, stored in elements 1 to N-1 of E. */ +/* > On exit, the contents of E are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 D(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 DOUBLE PRECISION array, dimension (f2cmax(1,2*N-2)) */ +/* > If JOBZ = 'N', WORK 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, the algorithm failed to converge; i */ +/* > off-diagonal elements of E 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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dstev_(char *jobz, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ldz, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer imax; + doublereal rmin, rmax, tnrm; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + logical wantz; + extern doublereal dlamch_(char *); + integer iscale; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *), dsteqr_(char *, integer *, doublereal *, doublereal * + , doublereal *, integer *, doublereal *, integer *); + doublereal smlnum, 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 */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -6; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEV ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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. */ + + iscale = 0; + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + } + +/* For eigenvalues only, call DSTERF. For eigenvalues and */ +/* eigenvectors, call DSTEQR. */ + + if (! wantz) { + dsterf_(n, &d__[1], &e[1], info); + } else { + dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], 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, &d__[1], &c__1); + } + + return 0; + +/* End of DSTEV */ + +} /* dstev_ */ + diff --git a/lapack-netlib/SRC/dstevd.c b/lapack-netlib/SRC/dstevd.c new file mode 100644 index 000000000..66d13ddf0 --- /dev/null +++ b/lapack-netlib/SRC/dstevd.c @@ -0,0 +1,713 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSTEVD 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 DSTEVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, */ +/* LIWORK, INFO ) */ + +/* CHARACTER JOBZ */ +/* INTEGER INFO, LDZ, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEVD computes all eigenvalues and, optionally, eigenvectors of a */ +/* > real symmetric tridiagonal matrix. 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] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A, stored in elements 1 to N-1 of E. */ +/* > On exit, the contents of E are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 D(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 DOUBLE PRECISION array, */ +/* > dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If JOBZ = 'N' or N <= 1 then LWORK must be at least 1. */ +/* > If JOBZ = 'V' and N > 1 then LWORK must be at least */ +/* > ( 1 + 4*N + N**2 ). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. */ +/* > If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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 E 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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dstevd_(char *jobz, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ldz, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + doublereal d__1; + + /* Local variables */ + doublereal rmin, rmax, tnrm; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer lwmin; + logical wantz; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *, integer *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + integer liwmin; + doublereal smlnum; + logical lquery; + 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 */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + liwmin = 1; + lwmin = 1; + if (*n > 1 && wantz) { +/* Computing 2nd power */ + i__1 = *n; + lwmin = (*n << 2) + 1 + i__1 * i__1; + liwmin = *n * 5 + 3; + } + + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -6; + } + + if (*info == 0) { + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEVD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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. */ + + iscale = 0; + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + } + +/* For eigenvalues only, call DSTERF. For eigenvalues and */ +/* eigenvectors, call DSTEDC. */ + + if (! wantz) { + dsterf_(n, &d__[1], &e[1], info); + } else { + dstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork, + &iwork[1], liwork, info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &d__[1], &c__1); + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSTEVD */ + +} /* dstevd_ */ + diff --git a/lapack-netlib/SRC/dstevr.c b/lapack-netlib/SRC/dstevr.c new file mode 100644 index 000000000..e76157378 --- /dev/null +++ b/lapack-netlib/SRC/dstevr.c @@ -0,0 +1,1029 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSTEVR 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 DSTEVR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, */ +/* M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, */ +/* LIWORK, INFO ) */ + +/* CHARACTER JOBZ, RANGE */ +/* INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER ISUPPZ( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEVR computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric tridiagonal matrix T. Eigenvalues and */ +/* > eigenvectors can be selected by specifying either a range of values */ +/* > or a range of indices for the desired eigenvalues. */ +/* > */ +/* > Whenever possible, DSTEVR calls DSTEMR to compute the */ +/* > eigenspectrum using Relatively Robust Representations. DSTEMR */ +/* > computes eigenvalues by the dqds algorithm, while orthogonal */ +/* > eigenvectors are computed from various "good" L D L^T representations */ +/* > (also known as Relatively Robust Representations). Gram-Schmidt */ +/* > orthogonalization is avoided as far as possible. More specifically, */ +/* > the various steps of the algorithm are as follows. For the i-th */ +/* > unreduced block of T, */ +/* > (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T */ +/* > is a relatively robust representation, */ +/* > (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high */ +/* > relative accuracy by the dqds algorithm, */ +/* > (c) If there is a cluster of close eigenvalues, "choose" sigma_i */ +/* > close to the cluster, and go to step (a), */ +/* > (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, */ +/* > compute the corresponding eigenvector by forming a */ +/* > rank-revealing twisted factorization. */ +/* > The desired accuracy of the output can be specified by the input */ +/* > parameter ABSTOL. */ +/* > */ +/* > For more details, see "A new O(n^2) algorithm for the symmetric */ +/* > tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, */ +/* > Computer Science Division Technical Report No. UCB//CSD-97-971, */ +/* > UC Berkeley, May 1997. */ +/* > */ +/* > */ +/* > Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested */ +/* > on machines which conform to the ieee-754 floating point standard. */ +/* > DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and */ +/* > when partial spectrum requests are made. */ +/* > */ +/* > Normal execution of DSTEMR may create NaNs and infinities and */ +/* > hence may abort due to a floating point exception in environments */ +/* > which do not handle NaNs and infinities in the ieee standard default */ +/* > manner. */ +/* > \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. */ +/* > For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ +/* > DSTEIN are called */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. */ +/* > On exit, D may be multiplied by a constant factor chosen */ +/* > to avoid over/underflow in computing the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (f2cmax(1,N-1)) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A in elements 1 to N-1 of E. */ +/* > On exit, E may be multiplied by a constant factor chosen */ +/* > to avoid over/underflow in computing the eigenvalues. */ +/* > \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 A to tridiagonal form. */ +/* > */ +/* > See "Computing Small Singular Values of Bidiagonal Matrices */ +/* > with Guaranteed High Relative Accuracy," by Demmel and */ +/* > Kahan, LAPACK Working Note #3. */ +/* > */ +/* > If high relative accuracy is important, set ABSTOL to */ +/* > DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ +/* > eigenvalues are computed to high relative accuracy when */ +/* > possible in future releases. The current code does not */ +/* > make any guarantees about high relative accuracy, but */ +/* > future releases will. See J. Barlow and J. Demmel, */ +/* > "Computing Accurate Eigensystems of Scaled Diagonally */ +/* > Dominant Matrices", LAPACK Working Note #7, for a discussion */ +/* > of which matrices define their eigenvalues to high relative */ +/* > accuracy. */ +/* > \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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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). */ +/* > 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] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The i-th eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* > ISUPPZ( 2*i ). */ +/* > Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal (and */ +/* > minimal) LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,20*N). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 optimal (and */ +/* > minimal) LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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: Internal error */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleOTHEReigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Inderjit Dhillon, IBM Almaden, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Ken Stanley, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dstevr_(char *jobz, char *range, integer *n, doublereal * + d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, + integer *iu, doublereal *abstol, integer *m, doublereal *w, + doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer imax; + doublereal rmin, rmax; + logical test; + doublereal tnrm; + integer itmp1, i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + char order[1]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer lwmin; + logical wantz; + integer jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, ieeeok, indibl, indifl; + logical valeig; + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + integer indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo; + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *), + dstemr_(char *, char *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, integer *, + logical *, doublereal *, integer *, integer *, integer *, integer + *); + integer liwmin; + logical tryrac; + integer nsplit; + doublereal smlnum; + logical lquery; + 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 */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + ieeeok = ilaenv_(&c__10, "DSTEVR", "N", &c__1, &c__2, &c__3, &c__4, ( + ftnlen)6, (ftnlen)1); + + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; +/* Computing MAX */ + i__1 = 1, i__2 = *n * 20; + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * 10; + liwmin = f2cmax(i__1,i__2); + + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } 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) { + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -17; + } else if (*liwork < liwmin && ! lquery) { + *info = -19; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEVR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = d__[1]; + } else { + if (*vl < d__[1] && *vu >= d__[1]) { + *m = 1; + w[1] = d__[1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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; + if (valeig) { + vll = *vl; + vuu = *vu; + } + + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } +/* Initialize indices into workspaces. Note: These indices are used only */ +/* if DSTERF or DSTEMR fail. */ +/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ +/* stores the block indices of each of the M<=N eigenvalues. */ + indibl = 1; +/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ +/* stores the starting and finishing indices of each block. */ + indisp = indibl + *n; +/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ +/* that corresponding to eigenvectors that fail to converge in */ +/* DSTEIN. This information is discarded; if any fail, the driver */ +/* returns INFO > 0. */ + indifl = indisp + *n; +/* INDIWO is the offset of the remaining integer workspace. */ + indiwo = indisp + *n; + +/* If all eigenvalues are desired, then */ +/* call DSTERF or DSTEMR. If this fails for some eigenvalue, then */ +/* try DSTEBZ. */ + + + test = FALSE_; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = TRUE_; + } + } + if ((alleig || test) && ieeeok == 1) { + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1); + if (! wantz) { + dcopy_(n, &d__[1], &c__1, &w[1], &c__1); + dsterf_(n, &w[1], &work[1], info); + } else { + dcopy_(n, &d__[1], &c__1, &work[*n + 1], &c__1); + if (*abstol <= *n * 2. * eps) { + tryrac = TRUE_; + } else { + tryrac = FALSE_; + } + i__1 = *lwork - (*n << 1); + dstemr_(jobz, "A", n, &work[*n + 1], &work[1], vl, vu, il, iu, m, + &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &work[ + (*n << 1) + 1], &i__1, &iwork[1], liwork, info); + + } + if (*info == 0) { + *m = *n; + goto L10; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & + nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[1], &iwork[ + indiwo], info); + + if (wantz) { + dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & + z__[z_offset], ldz, &work[1], &iwork[indiwo], &iwork[indifl], + info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L10: + 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]; + } +/* L20: */ + } + + if (i__ != 0) { + itmp1 = iwork[i__]; + w[i__] = w[j]; + iwork[i__] = iwork[j]; + w[j] = tmp1; + iwork[j] = itmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + } +/* L30: */ + } + } + +/* Causes problems with tests 19 & 20: */ +/* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 */ + + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSTEVR */ + +} /* dstevr_ */ + diff --git a/lapack-netlib/SRC/dstevx.c b/lapack-netlib/SRC/dstevx.c new file mode 100644 index 000000000..d4f9c1903 --- /dev/null +++ b/lapack-netlib/SRC/dstevx.c @@ -0,0 +1,901 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSTEVX 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 DSTEVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, */ +/* M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) */ + +/* CHARACTER JOBZ, RANGE */ +/* INTEGER IL, INFO, IU, LDZ, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric tridiagonal matrix A. 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] 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] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. */ +/* > On exit, D may be multiplied by a constant factor chosen */ +/* > to avoid over/underflow in computing the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (f2cmax(1,N-1)) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A in elements 1 to N-1 of E. */ +/* > On exit, E may be multiplied by a constant factor chosen */ +/* > to avoid over/underflow in computing the eigenvalues. */ +/* > \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. */ +/* > */ +/* > 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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 (INFO > 0), 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 DOUBLE PRECISION array, dimension (5*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 doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dstevx_(char *jobz, char *range, integer *n, doublereal * + d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, + integer *iu, doublereal *abstol, integer *m, doublereal *w, + doublereal *z__, integer *ldz, doublereal *work, 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 imax; + doublereal rmin, rmax; + logical test; + doublereal tnrm; + integer itmp1, i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + char order[1]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + logical wantz; + integer jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, indibl; + logical valeig; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + integer indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo; + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *); + integer indwrk; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer nsplit; + doublereal smlnum, 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 */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --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 (*n < 0) { + *info = -3; + } 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_("DSTEVX", &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] = d__[1]; + } else { + if (*vl < d__[1] && *vu >= d__[1]) { + *m = 1; + w[1] = d__[1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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; + if (valeig) { + vll = *vl; + vuu = *vu; + } else { + vll = 0.; + vuu = 0.; + } + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* If all eigenvalues are desired and ABSTOL is less than zero, then */ +/* call DSTERF or SSTEQR. 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, &d__[1], &c__1, &w[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1); + indwrk = *n + 1; + if (! wantz) { + dsterf_(n, &w[1], &work[1], info); + } else { + dsteqr_("I", n, &w[1], &work[1], &z__[z_offset], ldz, &work[ + indwrk], 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, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indwrk = 1; + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & + nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], & + iwork[indiwo], info); + + if (wantz) { + dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & + z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], + info); + } + +/* 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; + dswap_(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 DSTEVX */ + +} /* dstevx_ */ + diff --git a/lapack-netlib/SRC/dsycon.c b/lapack-netlib/SRC/dsycon.c new file mode 100644 index 000000000..2f68d987b --- /dev/null +++ b/lapack-netlib/SRC/dsycon.c @@ -0,0 +1,639 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYCON estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a real symmetric matrix A using the factorization */ +/* > A = U*D*U**T or A = L*D*L**T computed by DSYTRF. */ +/* > */ +/* > 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**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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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 DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsycon_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal * + work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer kase, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int dsytrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + --iwork; + + /* 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; + } else if (*anorm < 0.) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYCON", &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 */ + + for (i__ = *n; i__ >= 1; --i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + dsytrs_(uplo, n, &c__1, &a[a_offset], lda, &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 DSYCON */ + +} /* dsycon_ */ + diff --git a/lapack-netlib/SRC/dsycon_3.c b/lapack-netlib/SRC/dsycon_3.c new file mode 100644 index 000000000..4a1aa57c9 --- /dev/null +++ b/lapack-netlib/SRC/dsycon_3.c @@ -0,0 +1,680 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYCON_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYCON_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > DSYCON_3 estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a real symmetric matrix A using the factorization */ +/* > computed by DSYTRF_RK or DSYTRF_BK: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > This routine uses BLAS3 solver DSYTRS_3. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix: */ +/* > = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); */ +/* > = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > Diagonal of the block diagonal matrix D and factors U or L */ +/* > as computed by DSYTRF_RK and DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > should be provided on entry in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is not referenced in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF_RK or DSYTRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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 DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > June 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsycon_3_(char *uplo, integer *n, doublereal *a, + integer *lda, doublereal *e, integer *ipiv, doublereal *anorm, + doublereal *rcond, doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer kase; + extern /* Subroutine */ int dsytrs_3_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + doublereal ainvnm; + + +/* -- 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; + --iwork; + + /* 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; + } else if (*anorm < 0.) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYCON_3", &i__1, (ftnlen)8); + 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 */ + + for (i__ = *n; i__ >= 1; --i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + dsytrs_3_(uplo, n, &c__1, &a[a_offset], lda, &e[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 DSYCON_3 */ + +} /* dsycon_3__ */ + diff --git a/lapack-netlib/SRC/dsycon_rook.c b/lapack-netlib/SRC/dsycon_rook.c new file mode 100644 index 000000000..47e65967e --- /dev/null +++ b/lapack-netlib/SRC/dsycon_rook.c @@ -0,0 +1,653 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYCON_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYCON_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYCON_ROOK estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a real symmetric matrix A using the factorization */ +/* > A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK. */ +/* > */ +/* > 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**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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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 DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > April 2012, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsycon_rook_(char *uplo, integer *n, doublereal *a, + integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond, + doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int dsytrs_rook_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + integer kase, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + doublereal ainvnm; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + --iwork; + + /* 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; + } else if (*anorm < 0.) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYCON_ROOK", &i__1, (ftnlen)11); + 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 */ + + for (i__ = *n; i__ >= 1; --i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + dsytrs_rook_(uplo, n, &c__1, &a[a_offset], lda, &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 DSYCON_ROOK */ + +} /* dsycon_rook__ */ + diff --git a/lapack-netlib/SRC/dsyconv.c b/lapack-netlib/SRC/dsyconv.c new file mode 100644 index 000000000..e3965d483 --- /dev/null +++ b/lapack-netlib/SRC/dsyconv.c @@ -0,0 +1,764 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYCONV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYCONV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) */ + +/* CHARACTER UPLO, WAY */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYCONV convert A given by TRF into L and D and vice-versa. */ +/* > Get Non-diag elements of D (returned in workspace) and */ +/* > apply or reverse permutation done in TRF. */ +/* > \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] WAY */ +/* > \verbatim */ +/* > WAY is CHARACTER*1 */ +/* > = 'C': Convert */ +/* > = 'R': Revert */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > E stores the supdiagonal/subdiagonal of the symmetric 1-by-1 */ +/* > or 2-by-2 block diagonal matrix D in LDLT. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsyconv_(char *uplo, char *way, integer *n, doublereal * + a, integer *lda, integer *ipiv, doublereal *e, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + doublereal temp; + integer i__, j; + extern logical lsame_(char *, char *); + logical upper; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical convert; + + +/* -- 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; + --e; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + convert = lsame_(way, "C"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! convert && ! lsame_(way, "R")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYCONV", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* A is UPPER */ + +/* Convert A (A is upper) */ + +/* Convert VALUE */ + + if (convert) { + i__ = *n; + e[1] = 0.; + while(i__ > 1) { + if (ipiv[i__] < 0) { + e[i__] = a[i__ - 1 + i__ * a_dim1]; + e[i__ - 1] = 0.; + a[i__ - 1 + i__ * a_dim1] = 0.; + --i__; + } else { + e[i__] = 0.; + } + --i__; + } + +/* Convert PERMUTATIONS */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + temp = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = temp; +/* L12: */ + } + } + } else { + ip = -ipiv[i__]; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + temp = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = a[i__ - 1 + j * a_dim1]; + a[i__ - 1 + j * a_dim1] = temp; +/* L13: */ + } + } + --i__; + } + --i__; + } + } else { + +/* Revert A (A is upper) */ + + +/* Revert PERMUTATIONS */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + temp = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = temp; + } + } + } else { + ip = -ipiv[i__]; + ++i__; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + temp = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = a[i__ - 1 + j * a_dim1]; + a[i__ - 1 + j * a_dim1] = temp; + } + } + } + ++i__; + } + +/* Revert VALUE */ + + i__ = *n; + while(i__ > 1) { + if (ipiv[i__] < 0) { + a[i__ - 1 + i__ * a_dim1] = e[i__]; + --i__; + } + --i__; + } + } + } else { + +/* A is LOWER */ + + if (convert) { + +/* Convert A (A is lower) */ + + +/* Convert VALUE */ + + i__ = 1; + e[*n] = 0.; + while(i__ <= *n) { + if (i__ < *n && ipiv[i__] < 0) { + e[i__] = a[i__ + 1 + i__ * a_dim1]; + e[i__ + 1] = 0.; + a[i__ + 1 + i__ * a_dim1] = 0.; + ++i__; + } else { + e[i__] = 0.; + } + ++i__; + } + +/* Convert PERMUTATIONS */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + temp = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = temp; +/* L22: */ + } + } + } else { + ip = -ipiv[i__]; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + temp = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = a[i__ + 1 + j * a_dim1]; + a[i__ + 1 + j * a_dim1] = temp; +/* L23: */ + } + } + ++i__; + } + ++i__; + } + } else { + +/* Revert A (A is lower) */ + + +/* Revert PERMUTATIONS */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = temp; + } + } + } else { + ip = -ipiv[i__]; + --i__; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + temp = a[i__ + 1 + j * a_dim1]; + a[i__ + 1 + j * a_dim1] = a[ip + j * a_dim1]; + a[ip + j * a_dim1] = temp; + } + } + } + --i__; + } + +/* Revert VALUE */ + + i__ = 1; + while(i__ <= *n - 1) { + if (ipiv[i__] < 0) { + a[i__ + 1 + i__ * a_dim1] = e[i__]; + ++i__; + } + ++i__; + } + } + } + return 0; + +/* End of DSYCONV */ + +} /* dsyconv_ */ + diff --git a/lapack-netlib/SRC/dsyconvf.c b/lapack-netlib/SRC/dsyconvf.c new file mode 100644 index 000000000..9c7512e03 --- /dev/null +++ b/lapack-netlib/SRC/dsyconvf.c @@ -0,0 +1,956 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYCONVF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYCONVF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) */ + +/* CHARACTER UPLO, WAY */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > If parameter WAY = 'C': */ +/* > DSYCONVF converts the factorization output format used in */ +/* > DSYTRF provided on entry in parameter A into the factorization */ +/* > output format used in DSYTRF_RK (or DSYTRF_BK) that is stored */ +/* > on exit in parameters A and E. It also coverts in place details of */ +/* > the intechanges stored in IPIV from the format used in DSYTRF into */ +/* > the format used in DSYTRF_RK (or DSYTRF_BK). */ +/* > */ +/* > If parameter WAY = 'R': */ +/* > DSYCONVF performs the conversion in reverse direction, i.e. */ +/* > converts the factorization output format used in DSYTRF_RK */ +/* > (or DSYTRF_BK) provided on entry in parameters A and E into */ +/* > the factorization output format used in DSYTRF that is stored */ +/* > on exit in parameter A. It also coverts in place details of */ +/* > the intechanges stored in IPIV from the format used in DSYTRF_RK */ +/* > (or DSYTRF_BK) into the format used in DSYTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix A. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WAY */ +/* > \verbatim */ +/* > WAY is CHARACTER*1 */ +/* > = 'C': Convert */ +/* > = 'R': Revert */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > DSYTRF: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal part of A. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > DSYTRF_RK or DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > 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. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > DSYTRF_RK or DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > 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. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > DSYTRF: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal 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,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, just a workspace. */ +/* > */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > On exit, is not changed */ +/* > \endverbatim */ +/* . */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > On entry, details of the interchanges and the block */ +/* > structure of D in the format used in DSYTRF. */ +/* > On exit, details of the interchanges and the block */ +/* > structure of D in the format used in DSYTRF_RK */ +/* > ( or DSYTRF_BK). */ +/* > */ +/* > 1) If WAY ='R': */ +/* > On entry, details of the interchanges and the block */ +/* > structure of D in the format used in DSYTRF_RK */ +/* > ( or DSYTRF_BK). */ +/* > On exit, details of the interchanges and the block */ +/* > structure of D in the format used in DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ +/* ===================================================================== */ +/* Subroutine */ int dsyconvf_(char *uplo, char *way, integer *n, doublereal * + a, integer *lda, doublereal *e, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical convert; + + +/* -- 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; + --e; + --ipiv; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + convert = lsame_(way, "C"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! convert && ! lsame_(way, "R")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYCONVF", &i__1, (ftnlen)8); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Begin A is UPPER */ + + if (convert) { + +/* Convert A (A is upper) */ + + +/* Convert VALUE */ + +/* Assign superdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = *n; + e[1] = 0.; + while(i__ > 1) { + if (ipiv[i__] < 0) { + e[i__] = a[i__ - 1 + i__ * a_dim1]; + e[i__ - 1] = 0.; + a[i__ - 1 + i__ * a_dim1] = 0.; + --i__; + } else { + e[i__] = 0.; + } + --i__; + } + +/* Convert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of upper part of A */ +/* in factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + dswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, & + a[ip + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) */ + + ip = -ipiv[i__]; + if (i__ < *n) { + if (ip != i__ - 1) { + i__1 = *n - i__; + dswap_(&i__1, &a[i__ - 1 + (i__ + 1) * a_dim1], + lda, &a[ip + (i__ + 1) * a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is no interchnge of rows i and and IPIV(i), */ +/* so this should be reflected in IPIV format for */ +/* *SYTRF_RK ( or *SYTRF_BK) */ + + ipiv[i__] = i__; + + --i__; + + } + --i__; + } + + } else { + +/* Revert A (A is upper) */ + + +/* Revert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of upper part of A */ +/* in reverse factorization order where i increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + dswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) */ + + ++i__; + ip = -ipiv[i__]; + if (i__ < *n) { + if (ip != i__ - 1) { + i__1 = *n - i__; + dswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ - 1 + (i__ + 1) * a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is one interchange of rows i-1 and IPIV(i-1), */ +/* so this should be recorded in two consecutive entries */ +/* in IPIV format for *SYTRF */ + + ipiv[i__] = ipiv[i__ - 1]; + + } + ++i__; + } + +/* Revert VALUE */ +/* Assign superdiagonal entries of D from array E to */ +/* superdiagonal entries of A. */ + + i__ = *n; + while(i__ > 1) { + if (ipiv[i__] < 0) { + a[i__ - 1 + i__ * a_dim1] = e[i__]; + --i__; + } + --i__; + } + +/* End A is UPPER */ + + } + + } else { + +/* Begin A is LOWER */ + + if (convert) { + +/* Convert A (A is lower) */ + + +/* Convert VALUE */ +/* Assign subdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = 1; + e[*n] = 0.; + while(i__ <= *n) { + if (i__ < *n && ipiv[i__] < 0) { + e[i__] = a[i__ + 1 + i__ * a_dim1]; + e[i__ + 1] = 0.; + a[i__ + 1 + i__ * a_dim1] = 0.; + ++i__; + } else { + e[i__] = 0.; + } + ++i__; + } + +/* Convert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of lower part of A */ +/* in factorization order where k increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + dswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) */ + + ip = -ipiv[i__]; + if (i__ > 1) { + if (ip != i__ + 1) { + i__1 = i__ - 1; + dswap_(&i__1, &a[i__ + 1 + a_dim1], lda, &a[ip + + a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is no interchnge of rows i and and IPIV(i), */ +/* so this should be reflected in IPIV format for */ +/* *SYTRF_RK ( or *SYTRF_BK) */ + + ipiv[i__] = i__; + + ++i__; + + } + ++i__; + } + + } else { + +/* Revert A (A is lower) */ + + +/* Revert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of lower part of A */ +/* in reverse factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + dswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) */ + + --i__; + ip = -ipiv[i__]; + if (i__ > 1) { + if (ip != i__ + 1) { + i__1 = i__ - 1; + dswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + 1 + + a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is one interchange of rows i+1 and IPIV(i+1), */ +/* so this should be recorded in consecutive entries */ +/* in IPIV format for *SYTRF */ + + ipiv[i__] = ipiv[i__ + 1]; + + } + --i__; + } + +/* Revert VALUE */ +/* Assign subdiagonal entries of D from array E to */ +/* subgiagonal entries of A. */ + + i__ = 1; + while(i__ <= *n - 1) { + if (ipiv[i__] < 0) { + a[i__ + 1 + i__ * a_dim1] = e[i__]; + ++i__; + } + ++i__; + } + + } + +/* End A is LOWER */ + + } + return 0; + +/* End of DSYCONVF */ + +} /* dsyconvf_ */ + diff --git a/lapack-netlib/SRC/dsyconvf_rook.c b/lapack-netlib/SRC/dsyconvf_rook.c new file mode 100644 index 000000000..e3665627f --- /dev/null +++ b/lapack-netlib/SRC/dsyconvf_rook.c @@ -0,0 +1,947 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYCONVF_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYCONVF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) */ + +/* CHARACTER UPLO, WAY */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > If parameter WAY = 'C': */ +/* > DSYCONVF_ROOK converts the factorization output format used in */ +/* > DSYTRF_ROOK provided on entry in parameter A into the factorization */ +/* > output format used in DSYTRF_RK (or DSYTRF_BK) that is stored */ +/* > on exit in parameters A and E. IPIV format for DSYTRF_ROOK and */ +/* > DSYTRF_RK (or DSYTRF_BK) is the same and is not converted. */ +/* > */ +/* > If parameter WAY = 'R': */ +/* > DSYCONVF_ROOK performs the conversion in reverse direction, i.e. */ +/* > converts the factorization output format used in DSYTRF_RK */ +/* > (or DSYTRF_BK) provided on entry in parameters A and E into */ +/* > the factorization output format used in DSYTRF_ROOK that is stored */ +/* > on exit in parameter A. IPIV format for DSYTRF_ROOK and */ +/* > DSYTRF_RK (or DSYTRF_BK) is the same and is not converted. */ +/* > \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 A. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WAY */ +/* > \verbatim */ +/* > WAY is CHARACTER*1 */ +/* > = 'C': Convert */ +/* > = 'R': Revert */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > DSYTRF_ROOK: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal part of A. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > DSYTRF_RK or DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > 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. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > DSYTRF_RK or DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > 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. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > DSYTRF_ROOK: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal 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,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, just a workspace. */ +/* > */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > On exit, is not changed */ +/* > \endverbatim */ +/* . */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > On entry, details of the interchanges and the block */ +/* > structure of D as determined: */ +/* > 1) by DSYTRF_ROOK, if WAY ='C'; */ +/* > 2) by DSYTRF_RK (or DSYTRF_BK), if WAY ='R'. */ +/* > The IPIV format is the same for all these routines. */ +/* > */ +/* > On exit, is not changed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ +/* ===================================================================== */ +/* Subroutine */ int dsyconvf_rook_(char *uplo, char *way, integer *n, + doublereal *a, integer *lda, doublereal *e, integer *ipiv, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer ip2; + logical convert; + + +/* -- 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; + --e; + --ipiv; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + convert = lsame_(way, "C"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! convert && ! lsame_(way, "R")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYCONVF_ROOK", &i__1, (ftnlen)13); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Begin A is UPPER */ + + if (convert) { + +/* Convert A (A is upper) */ + + +/* Convert VALUE */ + +/* Assign superdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = *n; + e[1] = 0.; + while(i__ > 1) { + if (ipiv[i__] < 0) { + e[i__] = a[i__ - 1 + i__ * a_dim1]; + e[i__ - 1] = 0.; + a[i__ - 1 + i__ * a_dim1] = 0.; + --i__; + } else { + e[i__] = 0.; + } + --i__; + } + +/* Convert PERMUTATIONS */ + +/* Apply permutations to submatrices of upper part of A */ +/* in factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + dswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, & + a[ip + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i and IPIV(i) and i-1 and IPIV(i-1) */ +/* in A(1:i,N-i:N) */ + + ip = -ipiv[i__]; + ip2 = -ipiv[i__ - 1]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + dswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, & + a[ip + (i__ + 1) * a_dim1], lda); + } + if (ip2 != i__ - 1) { + i__1 = *n - i__; + dswap_(&i__1, &a[i__ - 1 + (i__ + 1) * a_dim1], + lda, &a[ip2 + (i__ + 1) * a_dim1], lda); + } + } + --i__; + + } + --i__; + } + + } else { + +/* Revert A (A is upper) */ + + +/* Revert PERMUTATIONS */ + +/* Apply permutations to submatrices of upper part of A */ +/* in reverse factorization order where i increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + dswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i-1 and IPIV(i-1) and i and IPIV(i) */ +/* in A(1:i,N-i:N) */ + + ++i__; + ip = -ipiv[i__]; + ip2 = -ipiv[i__ - 1]; + if (i__ < *n) { + if (ip2 != i__ - 1) { + i__1 = *n - i__; + dswap_(&i__1, &a[ip2 + (i__ + 1) * a_dim1], lda, & + a[i__ - 1 + (i__ + 1) * a_dim1], lda); + } + if (ip != i__) { + i__1 = *n - i__; + dswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ + (i__ + 1) * a_dim1], lda); + } + } + + } + ++i__; + } + +/* Revert VALUE */ +/* Assign superdiagonal entries of D from array E to */ +/* superdiagonal entries of A. */ + + i__ = *n; + while(i__ > 1) { + if (ipiv[i__] < 0) { + a[i__ - 1 + i__ * a_dim1] = e[i__]; + --i__; + } + --i__; + } + +/* End A is UPPER */ + + } + + } else { + +/* Begin A is LOWER */ + + if (convert) { + +/* Convert A (A is lower) */ + + +/* Convert VALUE */ +/* Assign subdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = 1; + e[*n] = 0.; + while(i__ <= *n) { + if (i__ < *n && ipiv[i__] < 0) { + e[i__] = a[i__ + 1 + i__ * a_dim1]; + e[i__ + 1] = 0.; + a[i__ + 1 + i__ * a_dim1] = 0.; + ++i__; + } else { + e[i__] = 0.; + } + ++i__; + } + +/* Convert PERMUTATIONS */ + +/* Apply permutations to submatrices of lower part of A */ +/* in factorization order where i increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + dswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i and IPIV(i) and i+1 and IPIV(i+1) */ +/* in A(i:N,1:i-1) */ + + ip = -ipiv[i__]; + ip2 = -ipiv[i__ + 1]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + dswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + + a_dim1], lda); + } + if (ip2 != i__ + 1) { + i__1 = i__ - 1; + dswap_(&i__1, &a[i__ + 1 + a_dim1], lda, &a[ip2 + + a_dim1], lda); + } + } + ++i__; + + } + ++i__; + } + + } else { + +/* Revert A (A is lower) */ + + +/* Revert PERMUTATIONS */ + +/* Apply permutations to submatrices of lower part of A */ +/* in reverse factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + dswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i+1 and IPIV(i+1) and i and IPIV(i) */ +/* in A(i:N,1:i-1) */ + + --i__; + ip = -ipiv[i__]; + ip2 = -ipiv[i__ + 1]; + if (i__ > 1) { + if (ip2 != i__ + 1) { + i__1 = i__ - 1; + dswap_(&i__1, &a[ip2 + a_dim1], lda, &a[i__ + 1 + + a_dim1], lda); + } + if (ip != i__) { + i__1 = i__ - 1; + dswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + + a_dim1], lda); + } + } + + } + --i__; + } + +/* Revert VALUE */ +/* Assign subdiagonal entries of D from array E to */ +/* subgiagonal entries of A. */ + + i__ = 1; + while(i__ <= *n - 1) { + if (ipiv[i__] < 0) { + a[i__ + 1 + i__ * a_dim1] = e[i__]; + ++i__; + } + ++i__; + } + + } + +/* End A is LOWER */ + + } + return 0; + +/* End of DSYCONVF_ROOK */ + +} /* dsyconvf_rook__ */ + diff --git a/lapack-netlib/SRC/dsyequb.c b/lapack-netlib/SRC/dsyequb.c new file mode 100644 index 000000000..9d7cd22c6 --- /dev/null +++ b/lapack-netlib/SRC/dsyequb.c @@ -0,0 +1,764 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYEQUB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEQUB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION AMAX, SCOND */ +/* CHARACTER UPLO */ +/* DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEQUB computes row and column scalings intended to equilibrate a */ +/* > symmetric matrix A (with respect to the Euclidean norm) and reduce */ +/* > its condition number. The scale factors S are computed by the BIN */ +/* > algorithm (see references) so that the scaled matrix B with elements */ +/* > B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of */ +/* > the smallest possible condition number over all possible diagonal */ +/* > scalings. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The N-by-N symmetric matrix whose scaling factors are to be */ +/* > computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, S contains the scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCOND */ +/* > \verbatim */ +/* > SCOND is DOUBLE PRECISION */ +/* > If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* > the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* > large nor too small, it is not worth scaling by S. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Largest absolute value of any matrix element. If AMAX is */ +/* > very close to overflow or very close to underflow, the */ +/* > matrix should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element is nonpositive. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n */ +/* > Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n */ +/* > DOI 10.1023/B:NUMA.0000016606.32820.69 \n */ +/* > Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsyequb_(char *uplo, integer *n, doublereal *a, integer * + lda, doublereal *s, doublereal *scond, doublereal *amax, doublereal * + work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1, d__2, d__3; + + /* Local variables */ + doublereal base; + integer iter; + doublereal smin, smax, d__; + integer i__, j; + doublereal t, u, scale; + extern logical lsame_(char *, char *); + doublereal c0, c1, c2, sumsq; + extern doublereal dlamch_(char *); + doublereal si; + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal smlnum, avg, std, tol; + + +/* -- 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; + --s; + --work; + + /* Function Body */ + *info = 0; + if (! (lsame_(uplo, "U") || 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_("DSYEQUB", &i__1, (ftnlen)7); + return 0; + } + up = lsame_(uplo, "U"); + *amax = 0.; + +/* Quick return if possible. */ + + if (*n == 0) { + *scond = 1.; + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 0.; + } + *amax = 0.; + if (up) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[i__] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[j] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + *amax = f2cmax(d__2,d__3); + } +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + s[j] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + *amax = f2cmax(d__2,d__3); + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + s[j] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + *amax = f2cmax(d__2,d__3); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[i__] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[j] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + *amax = f2cmax(d__2,d__3); + } + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + s[j] = 1. / s[j]; + } + tol = 1. / sqrt(*n * 2.); + for (iter = 1; iter <= 100; ++iter) { + scale = 0.; + sumsq = 0.; +/* beta = |A|s */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + if (up) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + j]; + work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + i__]; + } + work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + j]; + work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + i__]; + } + } + } +/* avg = s^T beta / n */ + avg = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + avg += s[i__] * work[i__]; + } + avg /= *n; + std = 0.; + i__1 = *n << 1; + for (i__ = *n + 1; i__ <= i__1; ++i__) { + work[i__] = s[i__ - *n] * work[i__ - *n] - avg; + } + dlassq_(n, &work[*n + 1], &c__1, &scale, &sumsq); + std = scale * sqrt(sumsq / *n); + if (std < tol * avg) { + goto L999; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + t = (d__1 = a[i__ + i__ * a_dim1], abs(d__1)); + si = s[i__]; + c2 = (*n - 1) * t; + c1 = (*n - 2) * (work[i__] - t * si); + c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg; + d__ = c1 * c1 - c0 * 4 * c2; + if (d__ <= 0.) { + *info = -1; + return 0; + } + si = c0 * -2 / (c1 + sqrt(d__)); + d__ = si - s[i__]; + u = 0.; + if (up) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + t = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + } + avg += (u + work[i__]) * d__ / *n; + s[i__] = si; + } + } +L999: + smlnum = dlamch_("SAFEMIN"); + bignum = 1. / smlnum; + smin = bignum; + smax = 0.; + t = 1. / sqrt(avg); + base = dlamch_("B"); + u = 1. / log(base); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = (integer) (u * log(s[i__] * t)); + s[i__] = pow_di(&base, &i__2); +/* Computing MIN */ + d__1 = smin, d__2 = s[i__]; + smin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[i__]; + smax = f2cmax(d__1,d__2); + } + *scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + + return 0; +} /* dsyequb_ */ + diff --git a/lapack-netlib/SRC/dsyev.c b/lapack-netlib/SRC/dsyev.c new file mode 100644 index 000000000..6ca4dad22 --- /dev/null +++ b/lapack-netlib/SRC/dsyev.c @@ -0,0 +1,715 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matr +ices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEV computes all eigenvalues and, optionally, eigenvectors of a */ +/* > real symmetric matrix A. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* > orthonormal eigenvectors of the matrix A. */ +/* > If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ +/* > or the upper triangle (if UPLO='U') of A, including the */ +/* > diagonal, is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= f2cmax(1,3*N-1). */ +/* > For optimal efficiency, LWORK >= (NB+2)*N, */ +/* > where NB is the blocksize for DSYTRD 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, 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 doubleSYeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a, + integer *lda, doublereal *w, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + 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 lower, wantz; + integer nb; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + integer indwrk; + extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *), + dsytrd_(char *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *); + integer llwork; + doublereal smlnum; + integer lwkopt; + logical lquery; + 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + + if (*info == 0) { + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); +/* Computing MAX */ + i__1 = 1, i__2 = (nb + 2) * *n; + lwkopt = f2cmax(i__1,i__2); + work[1] = (doublereal) lwkopt; + +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3 - 1; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEV ", &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] = a[a_dim1 + 1]; + work[1] = 2.; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + 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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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) { + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, + info); + } + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & + work[indwrk], &llwork, &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DORGTR to generate the orthogonal matrix, then call DSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & + llwork, &iinfo); + dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau], + 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); + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYEV */ + +} /* dsyev_ */ + diff --git a/lapack-netlib/SRC/dsyev_2stage.c b/lapack-netlib/SRC/dsyev_2stage.c new file mode 100644 index 000000000..3c76dedb6 --- /dev/null +++ b/lapack-netlib/SRC/dsyev_2stage.c @@ -0,0 +1,779 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for +SY matrices */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEV_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, */ +/* INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEV_2STAGE computes all eigenvalues and, optionally, eigenvectors of a */ +/* > real symmetric matrix A using the 2stage technique for */ +/* > the reduction to tridiagonal. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > Not available in this release. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* > orthonormal eigenvectors of the matrix A. */ +/* > If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ +/* > or the upper triangle (if UPLO='U') of A, including the */ +/* > diagonal, is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension LWORK */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* > otherwise */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, dimension) where */ +/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 2*N */ +/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ +/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ +/* > + (KD+1)*N + 2*N */ +/* > where KD is the blocking size of the reduction, */ +/* > FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the 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 November 2017 */ + +/* > \ingroup doubleSYeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsyev_2stage_(char *jobz, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *w, doublereal *work, integer + *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer inde; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + integer imax; + doublereal anrm, rmin, rmax; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int dsytrd_2stage_(char *, char *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *); + integer lhtrd, lwmin; + logical lower; + integer lwtrd; + logical wantz; + integer ib, kd; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + integer indwrk; + extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + integer llwork; + doublereal smlnum; + logical lquery; + doublereal eps; + integer indhous; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1; + + *info = 0; + if (! lsame_(jobz, "N")) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + + if (*info == 0) { + kd = ilaenv2stage_(&c__1, "DSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, & + c_n1); + ib = ilaenv2stage_(&c__2, "DSYTRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); + lwmin = (*n << 1) + lhtrd + lwtrd; + work[1] = (doublereal) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEV_2STAGE ", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = a[a_dim1 + 1]; + work[1] = 2.; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + 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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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) { + dlascl_(uplo, &c__0, &c__0, &c_b27, &sigma, n, n, &a[a_offset], lda, + info); + } + +/* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + indhous = indtau + *n; + indwrk = indhous + lhtrd; + llwork = *lwork - indwrk + 1; + + dsytrd_2stage_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[inde], & + work[indtau], &work[indhous], &lhtrd, &work[indwrk], &llwork, & + iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DORGTR to generate the orthogonal matrix, then call DSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { +/* Not available in this release, and argument checking should not */ +/* let it getting here */ + return 0; + dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & + llwork, &iinfo); + dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau], + 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); + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwmin; + + return 0; + +/* End of DSYEV_2STAGE */ + +} /* dsyev_2stage__ */ + diff --git a/lapack-netlib/SRC/dsyevd.c b/lapack-netlib/SRC/dsyevd.c new file mode 100644 index 000000000..8c5028fe7 --- /dev/null +++ b/lapack-netlib/SRC/dsyevd.c @@ -0,0 +1,785 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, */ +/* LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDA, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEVD computes all eigenvalues and, optionally, eigenvectors of a */ +/* > real symmetric matrix A. 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. */ +/* > */ +/* > Because of large use of BLAS of level 3, DSYEVD needs N**2 more */ +/* > workspace than DSYEVX. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* > orthonormal eigenvectors of the matrix A. */ +/* > If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ +/* > or the upper triangle (if UPLO='U') of A, including the */ +/* > diagonal, is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, */ +/* > dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N <= 1, LWORK must be at least 1. */ +/* > If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be at least */ +/* > 1 + 6*N + 2*N**2. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If N <= 1, LIWORK must be at least 1. */ +/* > If JOBZ = 'N' and 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 optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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 and JOBZ = 'N', then the algorithm failed */ +/* > to converge; i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to zero; */ +/* > if INFO = i and JOBZ = 'V', then the algorithm failed */ +/* > to compute an eigenvalue while working on the submatrix */ +/* > lying in rows and columns INFO/(N+1) through */ +/* > mod(INFO,N+1). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYeigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA \n */ +/* > Modified by Francoise Tisseur, University of Tennessee \n */ +/* > Modified description of INFO. Sven, 16 Feb 05. \n */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal * + a, integer *lda, doublereal *w, doublereal *work, integer *lwork, + integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer inde; + doublereal anrm, rmin, rmax; + integer lopt; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo, lwmin, liopt; + logical lower, wantz; + integer indwk2, llwrk2; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dstedc_(char *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *), dlacpy_( + char *, integer *, integer *, doublereal *, integer *, doublereal + *, integer *); + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + integer indwrk, liwmin; + extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), dsytrd_(char *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *); + integer llwork; + doublereal smlnum; + logical lquery; + 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + + if (*info == 0) { + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + lopt = lwmin; + liopt = liwmin; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1; + } +/* Computing MAX */ + i__1 = lwmin, i__2 = (*n << 1) + ilaenv_(&c__1, "DSYTRD", uplo, n, + &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + lopt = f2cmax(i__1,i__2); + liopt = liwmin; + } + work[1] = (doublereal) lopt; + iwork[1] = liopt; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVD", &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] = a[a_dim1 + 1]; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + 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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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) { + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, + info); + } + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + + dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & + work[indwrk], &llwork, &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ +/* tridiagonal matrix, then call DORMTR to multiply it by the */ +/* Householder transformations stored in A. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[ + indwrk], n, &work[indwk2], &llwrk2, &iinfo); + dlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (doublereal) lopt; + iwork[1] = liopt; + + return 0; + +/* End of DSYEVD */ + +} /* dsyevd_ */ + diff --git a/lapack-netlib/SRC/dsyevd_2stage.c b/lapack-netlib/SRC/dsyevd_2stage.c new file mode 100644 index 000000000..10e684887 --- /dev/null +++ b/lapack-netlib/SRC/dsyevd_2stage.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 DSYEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for + SY matrices */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEVD_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, */ +/* IWORK, LIWORK, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDA, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEVD_2STAGE computes all eigenvalues and, optionally, eigenvectors of a */ +/* > real symmetric matrix A using the 2stage technique for */ +/* > the reduction to tridiagonal. 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. */ +/* > Not available in this release. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* > orthonormal eigenvectors of the matrix A. */ +/* > If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ +/* > or the upper triangle (if UPLO='U') of A, including the */ +/* > diagonal, is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, */ +/* > dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N <= 1, LWORK must be at least 1. */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, dimension) where */ +/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 2*N+1 */ +/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ +/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ +/* > + (KD+1)*N + 2*N+1 */ +/* > where KD is the blocking size of the reduction, */ +/* > FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be at least */ +/* > 1 + 6*N + 2*N**2. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If N <= 1, LIWORK must be at least 1. */ +/* > If JOBZ = 'N' and 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 optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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 and JOBZ = 'N', then the algorithm failed */ +/* > to converge; i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to zero; */ +/* > if INFO = i and JOBZ = 'V', then the algorithm failed */ +/* > to compute an eigenvalue while working on the submatrix */ +/* > lying in rows and columns INFO/(N+1) through */ +/* > mod(INFO,N+1). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYeigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA \n */ +/* > Modified by Francoise Tisseur, University of Tennessee \n */ +/* > Modified description of INFO. Sven, 16 Feb 05. \n */ +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsyevd_2stage_(char *jobz, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *w, doublereal *work, integer + *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer inde; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + doublereal anrm, rmin, rmax; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int dsytrd_2stage_(char *, char *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *); + integer lhtrd, lwmin; + logical lower; + integer lwtrd; + logical wantz; + integer indwk2, ib, llwrk2, kd; + extern doublereal dlamch_(char *); + integer iscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dstedc_(char *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *), dlacpy_( + char *, integer *, integer *, doublereal *, integer *, doublereal + *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + integer indwrk, liwmin; + extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer llwork; + doublereal smlnum; + logical lquery; + doublereal eps; + integer indhous; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (! lsame_(jobz, "N")) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + + if (*info == 0) { + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else { + kd = ilaenv2stage_(&c__1, "DSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, + &c_n1); + ib = ilaenv2stage_(&c__2, "DSYTRD_2STAGE", jobz, n, &kd, &c_n1, & + c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1 + lhtrd + lwtrd; + } + } + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVD_2STAGE", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = a[a_dim1 + 1]; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + 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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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) { + dlascl_(uplo, &c__0, &c__0, &c_b27, &sigma, n, n, &a[a_offset], lda, + info); + } + +/* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + indhous = indtau + *n; + indwrk = indhous + lhtrd; + llwork = *lwork - indwrk + 1; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + + dsytrd_2stage_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[inde], & + work[indtau], &work[indhous], &lhtrd, &work[indwrk], &llwork, & + iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ +/* tridiagonal matrix, then call DORMTR to multiply it by the */ +/* Householder transformations stored in A. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { +/* Not available in this release, and argument checking should not */ +/* let it getting here */ + return 0; + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[ + indwrk], n, &work[indwk2], &llwrk2, &iinfo); + dlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSYEVD_2STAGE */ + +} /* dsyevd_2stage__ */ + diff --git a/lapack-netlib/SRC/dsyevr.c b/lapack-netlib/SRC/dsyevr.c new file mode 100644 index 000000000..5d2a07d56 --- /dev/null +++ b/lapack-netlib/SRC/dsyevr.c @@ -0,0 +1,1139 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEVR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, */ +/* ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, */ +/* IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER ISUPPZ( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEVR computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ +/* > selected by specifying either a range of values or a range of */ +/* > indices for the desired eigenvalues. */ +/* > */ +/* > DSYEVR first reduces the matrix A to tridiagonal form T with a call */ +/* > to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute */ +/* > the eigenspectrum using Relatively Robust Representations. DSTEMR */ +/* > computes eigenvalues by the dqds algorithm, while orthogonal */ +/* > eigenvectors are computed from various "good" L D L^T representations */ +/* > (also known as Relatively Robust Representations). Gram-Schmidt */ +/* > orthogonalization is avoided as far as possible. More specifically, */ +/* > the various steps of the algorithm are as follows. */ +/* > */ +/* > For each unreduced block (submatrix) of T, */ +/* > (a) Compute T - sigma I = L D L^T, so that L and D */ +/* > define all the wanted eigenvalues to high relative accuracy. */ +/* > This means that small relative changes in the entries of D and L */ +/* > cause only small relative changes in the eigenvalues and */ +/* > eigenvectors. The standard (unfactored) representation of the */ +/* > tridiagonal matrix T does not have this property in general. */ +/* > (b) Compute the eigenvalues to suitable accuracy. */ +/* > If the eigenvectors are desired, the algorithm attains full */ +/* > accuracy of the computed eigenvalues only right before */ +/* > the corresponding vectors have to be computed, see steps c) and d). */ +/* > (c) For each cluster of close eigenvalues, select a new */ +/* > shift close to the cluster, find a new factorization, and refine */ +/* > the shifted eigenvalues to suitable accuracy. */ +/* > (d) For each eigenvalue with a large enough relative separation compute */ +/* > the corresponding eigenvector by forming a rank revealing twisted */ +/* > factorization. Go back to (c) for any clusters that remain. */ +/* > */ +/* > The desired accuracy of the output can be specified by the input */ +/* > parameter ABSTOL. */ +/* > */ +/* > For more details, see DSTEMR's documentation and: */ +/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ +/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ +/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ +/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ +/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ +/* > 2004. Also LAPACK Working Note 154. */ +/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ +/* > tridiagonal eigenvalue/eigenvector problem", */ +/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ +/* > UC Berkeley, May 1997. */ +/* > */ +/* > */ +/* > Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested */ +/* > on machines which conform to the ieee-754 floating point standard. */ +/* > DSYEVR calls DSTEBZ and DSTEIN on non-ieee machines and */ +/* > when partial spectrum requests are made. */ +/* > */ +/* > Normal execution of DSTEMR may create NaNs and infinities and */ +/* > hence may abort due to a floating point exception in environments */ +/* > which do not handle NaNs and infinities in the ieee standard default */ +/* > manner. */ +/* > \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. */ +/* > For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ +/* > DSTEIN are called */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, the lower triangle (if UPLO='L') or the upper */ +/* > triangle (if UPLO='U') of A, including the diagonal, is */ +/* > destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \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 A to tridiagonal form. */ +/* > */ +/* > See "Computing Small Singular Values of Bidiagonal Matrices */ +/* > with Guaranteed High Relative Accuracy," by Demmel and */ +/* > Kahan, LAPACK Working Note #3. */ +/* > */ +/* > If high relative accuracy is important, set ABSTOL to */ +/* > DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ +/* > eigenvalues are computed to high relative accuracy when */ +/* > possible in future releases. The current code does not */ +/* > make any guarantees about high relative accuracy, but */ +/* > future releases will. See J. Barlow and J. Demmel, */ +/* > "Computing Accurate Eigensystems of Scaled Diagonally */ +/* > Dominant Matrices", LAPACK Working Note #7, for a discussion */ +/* > of which matrices define their eigenvalues to high relative */ +/* > accuracy. */ +/* > \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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 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. */ +/* > Supplying N columns is always safe. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The i-th eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* > ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal */ +/* > matrix). The support of the eigenvectors of A is typically */ +/* > 1:N because of the orthogonal transformations applied by DORMTR. */ +/* > Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,26*N). */ +/* > For optimal efficiency, LWORK >= (NB+6)*N, */ +/* > where NB is the f2cmax of the blocksize for DSYTRD and DORMTR */ +/* > 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] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: Internal error */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleSYeigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Inderjit Dhillon, IBM Almaden, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Ken Stanley, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Jason Riedy, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * + il, integer *iu, doublereal *abstol, integer *m, doublereal *w, + doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, 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; + integer i__, j, inddd, indee; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo; + char order[1]; + integer indwk; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer lwmin; + logical lower, wantz; + integer nb, jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, ieeeok, indibl, indifl; + logical valeig; + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal abstll, bignum; + integer indtau, indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo, indwkn; + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *), + dstemr_(char *, char *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, integer *, + logical *, doublereal *, integer *, integer *, integer *, integer + *); + integer liwmin; + logical tryrac; + extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer llwrkn, llwork, nsplit; + doublereal smlnum; + extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, integer *); + integer lwkopt; + logical lquery; + doublereal eps, vll, vuu, tmp1; + + +/* -- 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 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4, ( + ftnlen)6, (ftnlen)1); + + lower = lsame_(uplo, "L"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; + +/* Computing MAX */ + i__1 = 1, i__2 = *n * 26; + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * 10; + liwmin = f2cmax(i__1,i__2); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -8; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -9; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -10; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -15; + } else if (*lwork < lwmin && ! lquery) { + *info = -18; + } else if (*liwork < liwmin && ! lquery) { + *info = -20; + } + } + + if (*info == 0) { + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nb = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = (nb + 1) * *n; + lwkopt = f2cmax(i__1,lwmin); + work[1] = (doublereal) lwkopt; + iwork[1] = liwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + work[1] = 1.; + return 0; + } + + if (*n == 1) { + work[1] = 7.; + if (alleig || indeig) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } else { + if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + isuppz[1] = 1; + isuppz[2] = 1; + } + 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; + } + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j + 1; + dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); +/* L10: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); +/* L20: */ + } + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } +/* Initialize indices into workspaces. Note: The IWORK indices are */ +/* used only if DSTERF or DSTEMR fail. */ +/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */ +/* elementary reflectors used in DSYTRD. */ + indtau = 1; +/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */ + indd = indtau + *n; +/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */ +/* tridiagonal matrix from DSYTRD. */ + inde = indd + *n; +/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */ +/* -written by DSTEMR (the DSTERF path copies the diagonal to W). */ + inddd = inde + *n; +/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */ +/* -written while computing the eigenvalues in DSTERF and DSTEMR. */ + indee = inddd + *n; +/* INDWK is the starting offset of the left-over workspace, and */ +/* LLWORK is the remaining workspace size. */ + indwk = indee + *n; + llwork = *lwork - indwk + 1; +/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ +/* stores the block indices of each of the M<=N eigenvalues. */ + indibl = 1; +/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ +/* stores the starting and finishing indices of each block. */ + indisp = indibl + *n; +/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ +/* that corresponding to eigenvectors that fail to converge in */ +/* DSTEIN. This information is discarded; if any fail, the driver */ +/* returns INFO > 0. */ + indifl = indisp + *n; +/* INDIWO is the offset of the remaining integer workspace. */ + indiwo = indifl + *n; + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ + indtau], &work[indwk], &llwork, &iinfo); + +/* If all eigenvalues are desired */ +/* then call DSTERF or DSTEMR and DORMTR. */ + + if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) { + if (! wantz) { + dcopy_(n, &work[indd], &c__1, &w[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1); + + if (*abstol <= *n * 2. * eps) { + tryrac = TRUE_; + } else { + tryrac = FALSE_; + } + dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu, + m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, & + work[indwk], lwork, &iwork[1], liwork, info); + + + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEMR. */ + + if (wantz && *info == 0) { + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau] + , &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + } + + + if (*info == 0) { +/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are */ +/* undefined. */ + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ +/* Also call DSTEBZ and DSTEIN if DSTEMR fails. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], & + iwork[indifl], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ + z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +/* Jump here if DSTEMR/DSTEIN succeeded. */ +L30: + 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. Note: We do not sort the IFAIL portion of IWORK. */ +/* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do */ +/* not return this detailed information to the user. */ + + 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]; + } +/* L40: */ + } + + if (i__ != 0) { + w[i__] = w[j]; + w[j] = tmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + } +/* L50: */ + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwkopt; + iwork[1] = liwmin; + + return 0; + +/* End of DSYEVR */ + +} /* dsyevr_ */ + diff --git a/lapack-netlib/SRC/dsyevr_2stage.c b/lapack-netlib/SRC/dsyevr_2stage.c new file mode 100644 index 000000000..9b0411df7 --- /dev/null +++ b/lapack-netlib/SRC/dsyevr_2stage.c @@ -0,0 +1,1195 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for + SY matrices */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEVR_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ +/* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, */ +/* LWORK, IWORK, LIWORK, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER ISUPPZ( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric matrix A using the 2stage technique for */ +/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can be */ +/* > selected by specifying either a range of values or a range of */ +/* > indices for the desired eigenvalues. */ +/* > */ +/* > DSYEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call */ +/* > to DSYTRD. Then, whenever possible, DSYEVR_2STAGE calls DSTEMR to compute */ +/* > the eigenspectrum using Relatively Robust Representations. DSTEMR */ +/* > computes eigenvalues by the dqds algorithm, while orthogonal */ +/* > eigenvectors are computed from various "good" L D L^T representations */ +/* > (also known as Relatively Robust Representations). Gram-Schmidt */ +/* > orthogonalization is avoided as far as possible. More specifically, */ +/* > the various steps of the algorithm are as follows. */ +/* > */ +/* > For each unreduced block (submatrix) of T, */ +/* > (a) Compute T - sigma I = L D L^T, so that L and D */ +/* > define all the wanted eigenvalues to high relative accuracy. */ +/* > This means that small relative changes in the entries of D and L */ +/* > cause only small relative changes in the eigenvalues and */ +/* > eigenvectors. The standard (unfactored) representation of the */ +/* > tridiagonal matrix T does not have this property in general. */ +/* > (b) Compute the eigenvalues to suitable accuracy. */ +/* > If the eigenvectors are desired, the algorithm attains full */ +/* > accuracy of the computed eigenvalues only right before */ +/* > the corresponding vectors have to be computed, see steps c) and d). */ +/* > (c) For each cluster of close eigenvalues, select a new */ +/* > shift close to the cluster, find a new factorization, and refine */ +/* > the shifted eigenvalues to suitable accuracy. */ +/* > (d) For each eigenvalue with a large enough relative separation compute */ +/* > the corresponding eigenvector by forming a rank revealing twisted */ +/* > factorization. Go back to (c) for any clusters that remain. */ +/* > */ +/* > The desired accuracy of the output can be specified by the input */ +/* > parameter ABSTOL. */ +/* > */ +/* > For more details, see DSTEMR's documentation and: */ +/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ +/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ +/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ +/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ +/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ +/* > 2004. Also LAPACK Working Note 154. */ +/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ +/* > tridiagonal eigenvalue/eigenvector problem", */ +/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ +/* > UC Berkeley, May 1997. */ +/* > */ +/* > */ +/* > Note 1 : DSYEVR_2STAGE calls DSTEMR when the full spectrum is requested */ +/* > on machines which conform to the ieee-754 floating point standard. */ +/* > DSYEVR_2STAGE calls DSTEBZ and SSTEIN on non-ieee machines and */ +/* > when partial spectrum requests are made. */ +/* > */ +/* > Normal execution of DSTEMR may create NaNs and infinities and */ +/* > hence may abort due to a floating point exception in environments */ +/* > which do not handle NaNs and infinities in the ieee standard default */ +/* > manner. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > Not available in this release. */ +/* > \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. */ +/* > For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ +/* > DSTEIN are called */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, the lower triangle (if UPLO='L') or the upper */ +/* > triangle (if UPLO='U') of A, including the diagonal, is */ +/* > destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \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 A to tridiagonal form. */ +/* > */ +/* > See "Computing Small Singular Values of Bidiagonal Matrices */ +/* > with Guaranteed High Relative Accuracy," by Demmel and */ +/* > Kahan, LAPACK Working Note #3. */ +/* > */ +/* > If high relative accuracy is important, set ABSTOL to */ +/* > DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ +/* > eigenvalues are computed to high relative accuracy when */ +/* > possible in future releases. The current code does not */ +/* > make any guarantees about high relative accuracy, but */ +/* > future releases will. See J. Barlow and J. Demmel, */ +/* > "Computing Accurate Eigensystems of Scaled Diagonally */ +/* > Dominant Matrices", LAPACK Working Note #7, for a discussion */ +/* > of which matrices define their eigenvalues to high relative */ +/* > accuracy. */ +/* > \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) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 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. */ +/* > Supplying N columns is always safe. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The i-th eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* > ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal */ +/* > matrix). The support of the eigenvectors of A is typically */ +/* > 1:N because of the orthogonal transformations applied by DORMTR. */ +/* > Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, 26*N, dimension) where */ +/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 5*N */ +/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ +/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ +/* > + (KD+1)*N + 5*N */ +/* > where KD is the blocking size of the reduction, */ +/* > FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: Internal error */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleSYeigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Inderjit Dhillon, IBM Almaden, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Ken Stanley, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Jason Riedy, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > */ +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsyevr_2stage_(char *jobz, char *range, char *uplo, + integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal * + vu, integer *il, integer *iu, doublereal *abstol, integer *m, + doublereal *w, doublereal *z__, integer *ldz, integer *isuppz, + doublereal *work, integer *lwork, integer *iwork, integer *liwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer indd, inde; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + doublereal anrm; + integer imax; + doublereal rmin, rmax; + integer i__, j, inddd, indee; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo; + char order[1]; + integer indwk, lhtrd; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *), dsytrd_2stage_(char *, char *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *); + integer lwmin; + logical lower; + integer lwtrd; + logical wantz; + integer ib, kd, jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, ieeeok, indibl, indifl; + logical valeig; + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal abstll, bignum; + integer indtau, indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo, indwkn; + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *), + dstemr_(char *, char *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, integer *, + logical *, doublereal *, integer *, integer *, integer *, integer + *); + integer liwmin; + logical tryrac; + extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer llwrkn, llwork, nsplit; + doublereal smlnum; + logical lquery; + doublereal eps, vll, vuu; + integer indhous; + doublereal tmp1; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4, ( + ftnlen)6, (ftnlen)1); + + lower = lsame_(uplo, "L"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; + + kd = ilaenv2stage_(&c__1, "DSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, &c_n1); + ib = ilaenv2stage_(&c__2, "DSYTRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_2STAGE", jobz, n, &kd, &ib, &c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_2STAGE", jobz, n, &kd, &ib, &c_n1); +/* Computing MAX */ + i__1 = *n * 26, i__2 = *n * 5 + lhtrd + lwtrd; + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * 10; + liwmin = f2cmax(i__1,i__2); + + *info = 0; + if (! lsame_(jobz, "N")) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -8; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -9; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -10; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -15; + } else if (*lwork < lwmin && ! lquery) { + *info = -18; + } else if (*liwork < liwmin && ! lquery) { + *info = -20; + } + } + + if (*info == 0) { +/* NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) */ +/* NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) */ +/* LWKOPT = MAX( ( NB+1 )*N, LWMIN ) */ + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVR_2STAGE", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + work[1] = 1.; + return 0; + } + + if (*n == 1) { + work[1] = 7.; + if (alleig || indeig) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } else { + if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + isuppz[1] = 1; + isuppz[2] = 1; + } + 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; + } + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j + 1; + dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); +/* L10: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); +/* L20: */ + } + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } +/* Initialize indices into workspaces. Note: The IWORK indices are */ +/* used only if DSTERF or DSTEMR fail. */ +/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */ +/* elementary reflectors used in DSYTRD. */ + indtau = 1; +/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */ + indd = indtau + *n; +/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */ +/* tridiagonal matrix from DSYTRD. */ + inde = indd + *n; +/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */ +/* -written by DSTEMR (the DSTERF path copies the diagonal to W). */ + inddd = inde + *n; +/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */ +/* -written while computing the eigenvalues in DSTERF and DSTEMR. */ + indee = inddd + *n; +/* INDHOUS is the starting offset Householder storage of stage 2 */ + indhous = indee + *n; +/* INDWK is the starting offset of the left-over workspace, and */ +/* LLWORK is the remaining workspace size. */ + indwk = indhous + lhtrd; + llwork = *lwork - indwk + 1; +/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ +/* stores the block indices of each of the M<=N eigenvalues. */ + indibl = 1; +/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ +/* stores the starting and finishing indices of each block. */ + indisp = indibl + *n; +/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ +/* that corresponding to eigenvectors that fail to converge in */ +/* DSTEIN. This information is discarded; if any fail, the driver */ +/* returns INFO > 0. */ + indifl = indisp + *n; +/* INDIWO is the offset of the remaining integer workspace. */ + indiwo = indifl + *n; + +/* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. */ + + + dsytrd_2stage_(jobz, uplo, n, &a[a_offset], lda, &work[indd], &work[inde] + , &work[indtau], &work[indhous], &lhtrd, &work[indwk], &llwork, & + iinfo); + +/* If all eigenvalues are desired */ +/* then call DSTERF or DSTEMR and DORMTR. */ + + if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) { + if (! wantz) { + dcopy_(n, &work[indd], &c__1, &w[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1); + + if (*abstol <= *n * 2. * eps) { + tryrac = TRUE_; + } else { + tryrac = FALSE_; + } + dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu, + m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, & + work[indwk], lwork, &iwork[1], liwork, info); + + + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEMR. */ + + if (wantz && *info == 0) { + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau] + , &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + } + + + if (*info == 0) { +/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are */ +/* undefined. */ + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ +/* Also call DSTEBZ and DSTEIN if DSTEMR fails. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], & + iwork[indifl], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ + z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +/* Jump here if DSTEMR/DSTEIN succeeded. */ +L30: + 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. Note: We do not sort the IFAIL portion of IWORK. */ +/* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do */ +/* not return this detailed information to the user. */ + + 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]; + } +/* L40: */ + } + + if (i__ != 0) { + w[i__] = w[j]; + w[j] = tmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + } +/* L50: */ + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSYEVR_2STAGE */ + +} /* dsyevr_2stage__ */ + diff --git a/lapack-netlib/SRC/dsyevx.c b/lapack-netlib/SRC/dsyevx.c new file mode 100644 index 000000000..362a3bf6d --- /dev/null +++ b/lapack-netlib/SRC/dsyevx.c @@ -0,0 +1,1014 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, */ +/* ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, */ +/* IFAIL, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric matrix A. 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] 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, the lower triangle (if UPLO='L') or the upper */ +/* > triangle (if UPLO='U') of A, including the diagonal, is */ +/* > destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \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 A 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) */ +/* > On normal exit, the first M elements contain the selected */ +/* > eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* > otherwise 8*N. */ +/* > For optimal efficiency, LWORK >= (NB+3)*N, */ +/* > where NB is the f2cmax of the blocksize for DSYTRD and DORMTR */ +/* > 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] 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 doubleSYeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dsyevx_(char *jobz, char *range, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * + il, integer *iu, doublereal *abstol, integer *m, doublereal *w, + doublereal *z__, integer *ldz, doublereal *work, integer *lwork, + integer *iwork, integer *ifail, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, 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 *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + logical lower, wantz; + integer nb, jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, indibl; + logical valeig; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal abstll, bignum; + integer indtau, indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo, indwkn; + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *); + integer indwrk, lwkmin; + extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *), + dormtr_(char *, char *, char *, integer *, integer *, doublereal * + , integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer llwrkn, llwork, nsplit; + doublereal smlnum; + extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, integer *); + integer lwkopt; + logical lquery; + 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + lower = lsame_(uplo, "L"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lquery = *lwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -8; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -9; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -10; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -15; + } + } + + if (*info == 0) { + if (*n <= 1) { + lwkmin = 1; + work[1] = (doublereal) lwkmin; + } else { + lwkmin = *n << 3; + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, + &c_n1, (ftnlen)6, (ftnlen)1); + nb = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = lwkmin, i__2 = (nb + 3) * *n; + lwkopt = f2cmax(i__1,i__2); + work[1] = (doublereal) lwkopt; + } + + if (*lwork < lwkmin && ! lquery) { + *info = -17; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } else { + if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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; + } + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j + 1; + dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); +/* L10: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); +/* L20: */ + } + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + indtau = 1; + inde = indtau + *n; + indd = inde + *n; + indwrk = indd + *n; + llwork = *lwork - indwrk + 1; + dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ + indtau], &work[indwrk], &llwork, &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal to */ +/* zero, then call DSTERF or DORGTR and SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz); + dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] + , &llwork, &iinfo); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L30: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L40; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ + z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L40: + 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]; + } +/* L50: */ + } + + 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; + dswap_(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; + } + } +/* L60: */ + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYEVX */ + +} /* dsyevx_ */ + diff --git a/lapack-netlib/SRC/dsyevx_2stage.c b/lapack-netlib/SRC/dsyevx_2stage.c new file mode 100644 index 000000000..e006f2a0f --- /dev/null +++ b/lapack-netlib/SRC/dsyevx_2stage.c @@ -0,0 +1,1074 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for + SY matrices */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYEVX_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ +/* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, */ +/* LWORK, IWORK, IFAIL, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric matrix A using the 2stage technique for */ +/* > the reduction to tridiagonal. 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] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > Not available in this release. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > On exit, the lower triangle (if UPLO='L') or the upper */ +/* > triangle (if UPLO='U') of A, including the diagonal, is */ +/* > destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \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 A 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) */ +/* > On normal exit, the first M elements contain the selected */ +/* > eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* > otherwise */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, 8*N, dimension) where */ +/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 3*N */ +/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ +/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ +/* > + (KD+1)*N + 3*N */ +/* > where KD is the blocking size of the reduction, */ +/* > FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (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 doubleSYeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsyevx_2stage_(char *jobz, char *range, char *uplo, + integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal * + vu, integer *il, integer *iu, doublereal *abstol, integer *m, + doublereal *w, doublereal *z__, integer *ldz, doublereal *work, + integer *lwork, integer *iwork, integer *ifail, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer indd, inde; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + 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 dsytrd_2stage_(char *, char *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *); + integer lhtrd; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer lwmin; + logical lower; + integer lwtrd; + logical wantz; + integer ib, kd, jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, indibl; + logical valeig; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal abstll, bignum; + integer indtau, indisp; + extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *), + dsterf_(integer *, doublereal *, doublereal *, integer *); + integer indiwo, indwkn; + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *); + integer indwrk; + extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *), + dormtr_(char *, char *, char *, integer *, integer *, doublereal * + , integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer llwrkn, llwork, nsplit; + doublereal smlnum; + logical lquery; + doublereal eps, vll, vuu; + integer indhous; + doublereal tmp1; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + lower = lsame_(uplo, "L"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lquery = *lwork == -1; + + *info = 0; + if (! lsame_(jobz, "N")) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -8; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -9; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -10; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -15; + } + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + work[1] = (doublereal) lwmin; + } else { + kd = ilaenv2stage_(&c__1, "DSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, + &c_n1); + ib = ilaenv2stage_(&c__2, "DSYTRD_2STAGE", jobz, n, &kd, &c_n1, & + c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); +/* Computing MAX */ + i__1 = *n << 3, i__2 = *n * 3 + lhtrd + lwtrd; + lwmin = f2cmax(i__1,i__2); + work[1] = (doublereal) lwmin; + } + + if (*lwork < lwmin && ! lquery) { + *info = -17; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVX_2STAGE", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } else { + if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + 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; + } + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j + 1; + dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); +/* L10: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); +/* L20: */ + } + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. */ + + indtau = 1; + inde = indtau + *n; + indd = inde + *n; + indhous = indd + *n; + indwrk = indhous + lhtrd; + llwork = *lwork - indwrk + 1; + + dsytrd_2stage_(jobz, uplo, n, &a[a_offset], lda, &work[indd], &work[inde] + , &work[indtau], &work[indhous], &lhtrd, &work[indwrk], &llwork, & + iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal to */ +/* zero, then call DSTERF or DORGTR and SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz); + dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] + , &llwork, &iinfo); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L30: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L40; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ + z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L40: + 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]; + } +/* L50: */ + } + + 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; + dswap_(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; + } + } +/* L60: */ + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwmin; + + return 0; + +/* End of DSYEVX_2STAGE */ + +} /* dsyevx_2stage__ */ + diff --git a/lapack-netlib/SRC/dsygs2.c b/lapack-netlib/SRC/dsygs2.c new file mode 100644 index 000000000..1c3aa3e5f --- /dev/null +++ b/lapack-netlib/SRC/dsygs2.c @@ -0,0 +1,732 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factor +ization results obtained from spotrf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYGS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, ITYPE, LDA, LDB, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYGS2 reduces a real symmetric-definite generalized eigenproblem */ +/* > to standard form. */ +/* > */ +/* > If ITYPE = 1, the problem is A*x = lambda*B*x, */ +/* > and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */ +/* > */ +/* > 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**T or L**T *A*L. */ +/* > */ +/* > B must have been previously factorized as U**T *U or L*L**T by DPOTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITYPE */ +/* > \verbatim */ +/* > ITYPE is INTEGER */ +/* > = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ +/* > = 2 or 3: compute U*A*U**T or L**T *A*L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored, and how B has been factorized. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n by n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the transformed matrix, stored in the */ +/* > same format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > The triangular factor from the Cholesky factorization of B, */ +/* > as returned by DPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *, + integer *, doublereal *, integer *); + doublereal ct; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akk, 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + 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; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGS2", &i__1, (ftnlen)6); + return 0; + } + + if (*itype == 1) { + if (upper) { + +/* Compute inv(U**T)*A*inv(U) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the upper triangle of A(k:n,k:n) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; +/* Computing 2nd power */ + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( + k + 1) * a_dim1], lda); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda, + &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) + * a_dim1], lda); + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( + k + 1) * a_dim1], lda); + i__2 = *n - k; + dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + ( + k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], + lda); + } +/* L10: */ + } + } else { + +/* Compute inv(L)*A*inv(L**T) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the lower triangle of A(k:n,k:n) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; +/* Computing 2nd power */ + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + + 1 + k * a_dim1], &c__1); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1, + &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) + * a_dim1], lda); + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + + 1 + k * a_dim1], &c__1); + i__2 = *n - k; + dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1 + + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1], + &c__1); + } +/* L20: */ + } + } + } else { + if (upper) { + +/* Compute U*A*U**T */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the upper triangle of A(1:k,1:k) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset], + ldb, &a[k * a_dim1 + 1], &c__1); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + + 1], &c__1); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k * + b_dim1 + 1], &c__1, &a[a_offset], lda); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + + 1], &c__1); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1); +/* Computing 2nd power */ + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); +/* L30: */ + } + } else { + +/* Compute L**T *A*L */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the lower triangle of A(1:k,1:k) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset], + ldb, &a[k + a_dim1], lda); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k + + b_dim1], ldb, &a[a_offset], lda); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k + a_dim1], lda); +/* Computing 2nd power */ + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); +/* L40: */ + } + } + } + return 0; + +/* End of DSYGS2 */ + +} /* dsygs2_ */ + diff --git a/lapack-netlib/SRC/dsygst.c b/lapack-netlib/SRC/dsygst.c new file mode 100644 index 000000000..ff6ba32fa --- /dev/null +++ b/lapack-netlib/SRC/dsygst.c @@ -0,0 +1,781 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYGST */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYGST + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, ITYPE, LDA, LDB, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYGST reduces a real symmetric-definite generalized eigenproblem */ +/* > to standard form. */ +/* > */ +/* > If ITYPE = 1, the problem is A*x = lambda*B*x, */ +/* > and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */ +/* > */ +/* > 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**T or L**T*A*L. */ +/* > */ +/* > B must have been previously factorized as U**T*U or L*L**T by DPOTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITYPE */ +/* > \verbatim */ +/* > ITYPE is INTEGER */ +/* > = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ +/* > = 2 or 3: compute U*A*U**T or L**T*A*L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored and B is factored as */ +/* > U**T*U; */ +/* > = 'L': Lower triangle of A is stored and B is factored as */ +/* > L*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the transformed matrix, stored in the */ +/* > same format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > The triangular factor from the Cholesky factorization of B, */ +/* > as returned by DPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsygst_(integer *itype, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer k; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dsymm_( + char *, char *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + logical upper; + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dsygs2_( + integer *, char *, integer *, doublereal *, integer *, doublereal + *, integer *, integer *); + integer kb; + extern /* Subroutine */ int dsyr2k_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + 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; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGST", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "DSYGST", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dsygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + } else { + +/* Use blocked code */ + + if (*itype == 1) { + if (upper) { + +/* Compute inv(U**T)*A*inv(U) */ + + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = f2cmin(i__3,nb); + +/* Update the upper triangle of A(k:n,k:n) */ + + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); + if (k + kb <= *n) { + i__3 = *n - k - kb + 1; + dtrsm_("Left", uplo, "Transpose", "Non-unit", &kb, & + i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + + (k + kb) * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * + a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, + &c_b14, &a[k + (k + kb) * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a[k + + (k + kb) * a_dim1], lda, &b[k + (k + kb) * + b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * + a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * + a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, + &c_b14, &a[k + (k + kb) * a_dim1], lda); + i__3 = *n - k - kb + 1; + dtrsm_("Right", uplo, "No transpose", "Non-unit", &kb, + &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1] + , ldb, &a[k + (k + kb) * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute inv(L)*A*inv(L**T) */ + + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = f2cmin(i__3,nb); + +/* Update the lower triangle of A(k:n,k:n) */ + + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); + if (k + kb <= *n) { + i__3 = *n - k - kb + 1; + dtrsm_("Right", uplo, "Transpose", "Non-unit", &i__3, + &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k + + kb + k * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * + a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & + c_b14, &a[k + kb + k * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, &a[ + k + kb + k * a_dim1], lda, &b[k + kb + k * + b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * + a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * + a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & + c_b14, &a[k + kb + k * a_dim1], lda); + i__3 = *n - k - kb + 1; + dtrsm_("Left", uplo, "No transpose", "Non-unit", & + i__3, &kb, &c_b14, &b[k + kb + (k + kb) * + b_dim1], ldb, &a[k + kb + k * a_dim1], lda); + } +/* L20: */ + } + } + } else { + if (upper) { + +/* Compute U*A*U**T */ + + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = f2cmin(i__3,nb); + +/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */ + + i__3 = k - 1; + dtrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, & + kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1], + lda) + ; + i__3 = k - 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * + a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ + k * a_dim1 + 1], lda); + i__3 = k - 1; + dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a[k * + a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, + &a[a_offset], lda); + i__3 = k - 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * + a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ + k * a_dim1 + 1], lda); + i__3 = k - 1; + dtrmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb, + &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + + 1], lda); + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); +/* L30: */ + } + } else { + +/* Compute L**T*A*L */ + + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = f2cmin(i__3,nb); + +/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */ + + i__3 = k - 1; + dtrmm_("Right", uplo, "No transpose", "Non-unit", &kb, & + i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1], + lda); + i__3 = k - 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + + a_dim1], lda); + i__3 = k - 1; + dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a[k + + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[ + a_offset], lda); + i__3 = k - 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + + a_dim1], lda); + i__3 = k - 1; + dtrmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3, + &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1], + lda); + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); +/* L40: */ + } + } + } + } + return 0; + +/* End of DSYGST */ + +} /* dsygst_ */ + diff --git a/lapack-netlib/SRC/dsygv.c b/lapack-netlib/SRC/dsygv.c new file mode 100644 index 000000000..2ee424493 --- /dev/null +++ b/lapack-netlib/SRC/dsygv.c @@ -0,0 +1,730 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYGV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYGV computes all the eigenvalues, and optionally, the eigenvectors */ +/* > of a real generalized symmetric-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 symmetric 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > */ +/* > On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* > matrix Z of eigenvectors. The eigenvectors are normalized */ +/* > as follows: */ +/* > if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* > if ITYPE = 3, Z**T*inv(B)*Z = I. */ +/* > If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */ +/* > or the lower triangle (if UPLO='L') of A, including the */ +/* > diagonal, is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the symmetric positive definite matrix B. */ +/* > If UPLO = 'U', the leading N-by-N upper triangular part of B */ +/* > contains the upper triangular part of the matrix B. */ +/* > If UPLO = 'L', the leading N-by-N lower triangular part of B */ +/* > contains the lower triangular part of the matrix B. */ +/* > */ +/* > On exit, if INFO <= N, the part of B containing the matrix is */ +/* > overwritten by the triangular factor U or L from the Cholesky */ +/* > factorization B = U**T*U or B = L*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= f2cmax(1,3*N-1). */ +/* > For optimal efficiency, LWORK >= (NB+2)*N, */ +/* > where NB is the blocksize for DSYTRD 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: DPOTRF or DSYEV returned an error code: */ +/* > <= N: if INFO = i, DSYEV failed to converge; */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to 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 doubleSYeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dsygv_(integer *itype, char *jobz, char *uplo, integer * + n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *w, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer neig; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + char trans[1]; + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dsyev_(char *, char *, integer *, doublereal * + , integer *, doublereal *, doublereal *, integer *, integer *); + logical wantz; + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *, + integer *, integer *); + integer lwkmin; + extern /* Subroutine */ int dsygst_(integer *, char *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --w; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -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 (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3 - 1; + lwkmin = f2cmax(i__1,i__2); + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); +/* Computing MAX */ + i__1 = lwkmin, i__2 = (nb + 2) * *n; + lwkopt = f2cmax(i__1,i__2); + work[1] = (doublereal) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -11; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGV ", &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. */ + + dpotrf_(uplo, n, &b[b_offset], ldb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, 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)**T*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + dtrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[ + b_offset], ldb, &a[a_offset], lda); + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U**T*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + dtrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[ + b_offset], ldb, &a[a_offset], lda); + } + } + + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DSYGV */ + +} /* dsygv_ */ + diff --git a/lapack-netlib/SRC/dsygv_2stage.c b/lapack-netlib/SRC/dsygv_2stage.c new file mode 100644 index 000000000..314de956d --- /dev/null +++ b/lapack-netlib/SRC/dsygv_2stage.c @@ -0,0 +1,787 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYGV_2STAGE */ + +/* @precisions fortran d -> s */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYGV_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, */ +/* WORK, LWORK, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYGV_2STAGE computes all the eigenvalues, and optionally, the eigenvectors */ +/* > of a real generalized symmetric-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 symmetric and B is also */ +/* > positive definite. */ +/* > This routine use the 2stage technique for the reduction to tridiagonal */ +/* > which showed higher performance on recent architecture and for large */ +/* > sizes N>2000. */ +/* > \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. */ +/* > Not available in this release. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > */ +/* > On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* > matrix Z of eigenvectors. The eigenvectors are normalized */ +/* > as follows: */ +/* > if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* > if ITYPE = 3, Z**T*inv(B)*Z = I. */ +/* > If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */ +/* > or the lower triangle (if UPLO='L') of A, including the */ +/* > diagonal, is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the symmetric positive definite matrix B. */ +/* > If UPLO = 'U', the leading N-by-N upper triangular part of B */ +/* > contains the upper triangular part of the matrix B. */ +/* > If UPLO = 'L', the leading N-by-N lower triangular part of B */ +/* > contains the lower triangular part of the matrix B. */ +/* > */ +/* > On exit, if INFO <= N, the part of B containing the matrix is */ +/* > overwritten by the triangular factor U or L from the Cholesky */ +/* > factorization B = U**T*U or B = L*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* > otherwise */ +/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ +/* > LWORK = MAX(1, dimension) where */ +/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 2*N */ +/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ +/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ +/* > + (KD+1)*N + 2*N */ +/* > where KD is the blocking size of the reduction, */ +/* > FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ +/* > */ +/* > 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: DPOTRF or DSYEV returned an error code: */ +/* > <= N: if INFO = i, DSYEV failed to converge; */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not converge to 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 November 2017 */ + +/* > \ingroup doubleSYeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > All details about the 2stage techniques are available in: */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsygv_2stage_(integer *itype, char *jobz, char *uplo, + integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *w, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer neig; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + extern /* Subroutine */ int dsyev_2stage_(char *, char *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + extern logical lsame_(char *, char *); + integer lhtrd; + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer lwmin; + char trans[1]; + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + integer lwtrd; + logical wantz; + integer ib, kd; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpotrf_( + char *, integer *, doublereal *, integer *, integer *), + dsygst_(integer *, char *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *); + logical lquery; + + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --w; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! lsame_(jobz, "N")) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + + if (*info == 0) { + kd = ilaenv2stage_(&c__1, "DSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, & + c_n1); + ib = ilaenv2stage_(&c__2, "DSYTRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1); + lhtrd = ilaenv2stage_(&c__3, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); + lwtrd = ilaenv2stage_(&c__4, "DSYTRD_2STAGE", jobz, n, &kd, &ib, & + c_n1); + lwmin = (*n << 1) + lhtrd + lwtrd; + work[1] = (doublereal) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGV_2STAGE ", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpotrf_(uplo, n, &b[b_offset], ldb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + dsyev_2stage_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, + 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)**T*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + dtrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b26, &b[ + b_offset], ldb, &a[a_offset], lda); + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U**T*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + dtrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b26, &b[ + b_offset], ldb, &a[a_offset], lda); + } + } + + work[1] = (doublereal) lwmin; + return 0; + +/* End of DSYGV_2STAGE */ + +} /* dsygv_2stage__ */ + diff --git a/lapack-netlib/SRC/dsygvd.c b/lapack-netlib/SRC/dsygvd.c new file mode 100644 index 000000000..8f7836deb --- /dev/null +++ b/lapack-netlib/SRC/dsygvd.c @@ -0,0 +1,794 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYGVD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYGVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, */ +/* LWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYGVD computes all the eigenvalues, and optionally, the eigenvectors */ +/* > of a real generalized symmetric-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 symmetric 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > */ +/* > On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* > matrix Z of eigenvectors. The eigenvectors are normalized */ +/* > as follows: */ +/* > if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* > if ITYPE = 3, Z**T*inv(B)*Z = I. */ +/* > If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */ +/* > or the lower triangle (if UPLO='L') of A, including the */ +/* > diagonal, is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the symmetric matrix B. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of B contains the */ +/* > upper triangular part of the matrix B. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of B contains */ +/* > the lower triangular part of the matrix B. */ +/* > */ +/* > On exit, if INFO <= N, the part of B containing the matrix is */ +/* > overwritten by the triangular factor U or L from the Cholesky */ +/* > factorization B = U**T*U or B = L*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N <= 1, LWORK >= 1. */ +/* > If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. */ +/* > If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK and IWORK */ +/* > arrays, returns these values as the first entries of the WORK */ +/* > and IWORK arrays, and no error message related to LWORK 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 optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If N <= 1, LIWORK >= 1. */ +/* > If JOBZ = 'N' and 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 optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK 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: DPOTRF or DSYEVD returned an error code: */ +/* > <= N: if INFO = i and JOBZ = 'N', then the algorithm */ +/* > failed to converge; i off-diagonal elements of an */ +/* > intermediate tridiagonal form did not converge to */ +/* > zero; */ +/* > if INFO = i and JOBZ = 'V', then the algorithm */ +/* > failed to compute an eigenvalue while working on */ +/* > the submatrix lying in rows and columns INFO/(N+1) */ +/* > through mod(INFO,N+1); */ +/* > > 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 doubleSYeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Modified so that no backsubstitution is performed if DSYEVD fails to */ +/* > converge (NEIG in old code could be greater than N causing out of */ +/* > bounds reference to A - reported by Ralf Meyer). Also corrected the */ +/* > description of INFO and the test on ITYPE. Sven, 16 Feb 05. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsygvd_(integer *itype, char *jobz, char *uplo, integer * + n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *w, doublereal *work, integer *lwork, integer *iwork, + integer *liwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + doublereal d__1, d__2; + + /* Local variables */ + integer lopt; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer lwmin; + char trans[1]; + integer liopt; + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper, wantz; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dpotrf_( + char *, integer *, doublereal *, integer *, integer *); + integer liwmin; + extern /* Subroutine */ int dsyevd_(char *, char *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *), dsygst_(integer *, char *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *); + logical lquery; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --w; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1; + } + lopt = lwmin; + liopt = liwmin; + 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 (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + + if (*info == 0) { + work[1] = (doublereal) lopt; + iwork[1] = liopt; + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGVD", &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. */ + + dpotrf_(uplo, n, &b[b_offset], ldb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + dsyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[ + 1], liwork, info); +/* Computing MAX */ + d__1 = (doublereal) lopt; + lopt = (integer) f2cmax(d__1,work[1]); +/* Computing MAX */ + d__1 = (doublereal) liopt, d__2 = (doublereal) iwork[1]; + liopt = (integer) f2cmax(d__1,d__2); + + if (wantz && *info == 0) { + +/* Backtransform eigenvectors to the original problem. */ + + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + dtrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset] + , ldb, &a[a_offset], lda); + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U**T*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + dtrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset] + , ldb, &a[a_offset], lda); + } + } + + work[1] = (doublereal) lopt; + iwork[1] = liopt; + + return 0; + +/* End of DSYGVD */ + +} /* dsygvd_ */ + diff --git a/lapack-netlib/SRC/dsygvx.c b/lapack-netlib/SRC/dsygvx.c new file mode 100644 index 000000000..4a305c93c --- /dev/null +++ b/lapack-netlib/SRC/dsygvx.c @@ -0,0 +1,888 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYGVX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYGVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, */ +/* VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, */ +/* LWORK, IWORK, IFAIL, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYGVX computes selected eigenvalues, and optionally, eigenvectors */ +/* > of a real generalized symmetric-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 symmetric 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 triangle of A and B are stored; */ +/* > = 'L': Lower triangle of A and B are stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix pencil (A,B). N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of A contains the */ +/* > upper triangular part of the matrix A. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of A contains */ +/* > the lower triangular part of the matrix A. */ +/* > */ +/* > On exit, the lower triangle (if UPLO='L') or the upper */ +/* > triangle (if UPLO='U') of A, including the diagonal, is */ +/* > destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the symmetric matrix B. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of B contains the */ +/* > upper triangular part of the matrix B. If UPLO = 'L', */ +/* > the leading N-by-N lower triangular part of B contains */ +/* > the lower triangular part of the matrix B. */ +/* > */ +/* > On exit, if INFO <= N, the part of B containing the matrix is */ +/* > overwritten by the triangular factor U or L from the Cholesky */ +/* > factorization B = U**T*U or B = L*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION */ +/* > 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 C to tridiagonal form, where C is the symmetric */ +/* > matrix of the standard symmetric problem to which the */ +/* > generalized problem is transformed. */ +/* > */ +/* > 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 DOUBLE PRECISION array, dimension (LDZ, f2cmax(1,M)) */ +/* > 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**T*B*Z = I; */ +/* > if ITYPE = 3, Z**T*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 DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= f2cmax(1,8*N). */ +/* > For optimal efficiency, LWORK >= (NB+3)*N, */ +/* > where NB is the blocksize for DSYTRD 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] 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: DPOTRF or DSYEVX returned an error code: */ +/* > <= N: if INFO = i, DSYEVX 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 doubleSYeigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dsygvx_(integer *itype, char *jobz, char *range, char * + uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer + *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu, + doublereal *abstol, integer *m, doublereal *w, doublereal *z__, + integer *ldz, doublereal *work, integer *lwork, integer *iwork, + integer *ifail, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + char trans[1]; + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper, wantz; + integer nb; + logical alleig, indeig, valeig; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *, + integer *, integer *); + integer lwkmin; + extern /* Subroutine */ int dsygst_(integer *, char *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int dsyevx_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, 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..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + upper = lsame_(uplo, "U"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lquery = *lwork == -1; + + *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 (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -11; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -12; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -13; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -18; + } + } + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 3; + lwkmin = f2cmax(i__1,i__2); + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); +/* Computing MAX */ + i__1 = lwkmin, i__2 = (nb + 3) * *n; + lwkopt = f2cmax(i__1,i__2); + work[1] = (doublereal) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGVX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpotrf_(uplo, n, &b[b_offset], ldb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + dsyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol, + m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &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)**T*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + dtrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] + , ldb, &z__[z_offset], ldz); + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U**T*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + dtrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] + , ldb, &z__[z_offset], ldz); + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYGVX */ + +} /* dsygvx_ */ + diff --git a/lapack-netlib/SRC/dsyrfs.c b/lapack-netlib/SRC/dsyrfs.c new file mode 100644 index 000000000..f491eaa44 --- /dev/null +++ b/lapack-netlib/SRC/dsyrfs.c @@ -0,0 +1,888 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, */ +/* X, LDX, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is symmetric indefinite, 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular part */ +/* > of the matrix A, and the strictly lower triangular part of A */ +/* > is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of A contains the lower triangular part of */ +/* > the matrix A, and the strictly upper triangular part of A is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The factored form of the matrix A. AF contains the block */ +/* > diagonal matrix D and the multipliers used to obtain the */ +/* > factor U or L from the factorization A = U*D*U**T or */ +/* > A = L*D*L**T as computed by DSYTRF. */ +/* > \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 DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by DSYTRS. */ +/* > 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 DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer * + ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, + doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), daxpy_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + integer count; + logical upper; + extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dlacn2_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + doublereal xk; + integer nz; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal lstres; + extern /* Subroutine */ int dsytrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, 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 */ + 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; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + 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 (*ldaf < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldx < f2cmax(1,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYRFS", &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 */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, + &c_b14, &work[*n + 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__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ + i__ + j * x_dim1], abs(d__2)); +/* L40: */ + } + work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) * + xk + s; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ + i__ + j * x_dim1], abs(d__2)); +/* L60: */ + } + work[k] += s; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = f2cmax(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(d__2,d__3); + } +/* 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. */ + + dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n + + 1], n, info); + daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(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 DLACN2 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 (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**T). */ + + dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + *n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L120: */ + } + dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + *n + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = f2cmax(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DSYRFS */ + +} /* dsyrfs_ */ + diff --git a/lapack-netlib/SRC/dsyrfsx.c b/lapack-netlib/SRC/dsyrfsx.c new file mode 100644 index 000000000..94b778865 --- /dev/null +++ b/lapack-netlib/SRC/dsyrfsx.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 DSYRFSX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYRFSX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, */ +/* S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER UPLO, EQUED */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, */ +/* $ N_ERR_BNDS */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ X( LDX, * ), WORK( * ) */ +/* DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYRFSX improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is symmetric indefinite, and */ +/* > provides error bounds and backward error estimates for the */ +/* > solution. In addition to normwise error bound, the code provides */ +/* > maximum componentwise error bound if possible. See comments for */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */ +/* > */ +/* > The original system of linear equations may have been equilibrated */ +/* > before calling this routine, as described by arguments EQUED and S */ +/* > below. In this case, the solution and error bounds returned are */ +/* > for the original unequilibrated system. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > Some optional parameters are bundled in the PARAMS array. These */ +/* > settings determine how refinement is performed, but often the */ +/* > defaults are acceptable. If the defaults are acceptable, users */ +/* > can pass NPARAMS = 0 which prevents the source code from accessing */ +/* > the PARAMS argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done to A */ +/* > before calling this routine. This is needed to compute */ +/* > the solution and error bounds correctly. */ +/* > = 'N': No equilibration */ +/* > = 'Y': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(S) * A * diag(S). */ +/* > The right hand side B has been changed accordingly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular */ +/* > part of the matrix A, and the strictly lower triangular */ +/* > part of A is not referenced. If UPLO = 'L', the leading */ +/* > N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The factored form of the matrix A. AF contains the block */ +/* > diagonal matrix D and the multipliers used to obtain the */ +/* > factor U or L from the factorization A = U*D*U**T or A = */ +/* > L*D*L**T as computed by DSYTRF. */ +/* > \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 DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. If EQUED = 'Y', A is multiplied on */ +/* > the left and right by diag(S). S is an input argument if FACT = */ +/* > 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ +/* > = 'Y', each element of S must be positive. If S is output, each */ +/* > element of S is a power of the radix. If S is input, each element */ +/* > of S 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 DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by DGETRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > Componentwise relative backward error. This is the */ +/* > componentwise relative backward error of each solution vector X(j) */ +/* > (i.e., the smallest relative change in any element of A or B that */ +/* > makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_ERR_BNDS */ +/* > \verbatim */ +/* > N_ERR_BNDS is INTEGER */ +/* > Number of error bounds to return for each right hand side */ +/* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* > ERR_BNDS_COMP below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NPARAMS */ +/* > \verbatim */ +/* > NPARAMS is INTEGER */ +/* > Specifies the number of parameters set in PARAMS. If <= 0, the */ +/* > PARAMS array is never referenced and default values are used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PARAMS */ +/* > \verbatim */ +/* > PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) */ +/* > Specifies algorithm parameters. If an entry is < 0.0, then */ +/* > that entry will be filled with default value used for that */ +/* > parameter. Only positions up to NPARAMS are accessed; defaults */ +/* > are used for higher-numbered parameters. */ +/* > */ +/* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* > refinement or not. */ +/* > Default: 1.0D+0 */ +/* > = 0.0: No refinement is performed, and no error bounds are */ +/* > computed. */ +/* > = 1.0: Use the double-precision refinement algorithm, */ +/* > possibly with doubled-single computations if the */ +/* > compilation environment does not support DOUBLE */ +/* > PRECISION. */ +/* > (other values are reserved for future use) */ +/* > */ +/* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* > computations allowed for refinement. */ +/* > Default: 10 */ +/* > Aggressive: Set to 100 to permit convergence using approximate */ +/* > factorizations or factorizations other than LU. If */ +/* > the factorization uses a technique other than */ +/* > Gaussian elimination, the guarantees in */ +/* > err_bnds_norm and err_bnds_comp may no longer be */ +/* > trustworthy. */ +/* > */ +/* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* > will attempt to find a solution with small componentwise */ +/* > relative error in the double-precision algorithm. Positive */ +/* > is true, 0.0 is false. */ +/* > Default: 1.0 (attempt componentwise convergence) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. The solution to every right-hand side is */ +/* > guaranteed. */ +/* > < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly singular, so */ +/* > the solution and error bounds could not be computed. RCOND = 0 */ +/* > is returned. */ +/* > = N+J: The solution corresponding to the Jth right-hand side is */ +/* > not guaranteed. The solutions corresponding to other right- */ +/* > hand sides K with K > J may not be guaranteed as well, but */ +/* > only the first such right-hand side is reported. If a small */ +/* > componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* > the Jth right-hand side is the first with a normwise error */ +/* > bound that is not guaranteed (the smallest J such */ +/* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* > the Jth right-hand side is the first with either a normwise or */ +/* > componentwise error bound that is not guaranteed (the smallest */ +/* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* > about all of the right-hand sides check ERR_BNDS_NORM or */ +/* > ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsyrfsx_(char *uplo, char *equed, integer *n, integer * + nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, + integer *ipiv, doublereal *s, doublereal *b, integer *ldb, doublereal + *x, integer *ldx, doublereal *rcond, doublereal *berr, integer * + n_err_bnds__, doublereal *err_bnds_norm__, doublereal * + err_bnds_comp__, integer *nparams, doublereal *params, doublereal * + work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + doublereal d__1, d__2; + + /* Local variables */ + doublereal illrcond_thresh__, unstable_thresh__; + extern /* Subroutine */ int dla_syrfsx_extended_(integer *, char *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, logical *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, logical *, integer *); + doublereal err_lbnd__; + char norm[1]; + integer ref_type__; + logical ignore_cwise__; + integer j; + extern logical lsame_(char *, char *); + doublereal anorm; + logical rcequ; + doublereal rcond_tmp__; + integer prec_type__; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dsycon_(char *, integer *, doublereal *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *); + extern integer ilaprec_(char *); + integer ithresh, n_norms__; + doublereal rthresh; + extern doublereal dla_syrcond_(char *, integer *, doublereal *, integer * + , doublereal *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *); + doublereal cwise_wrong__; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ================================================================== */ + + +/* Check the input parameters. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + 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; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + ref_type__ = 1; + if (*nparams >= 1) { + if (params[1] < 0.) { + params[1] = 1.; + } else { + ref_type__ = (integer) params[1]; + } + } + +/* Set default parameters. */ + + illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon"); + ithresh = 10; + rthresh = .5; + unstable_thresh__ = .25; + ignore_cwise__ = FALSE_; + + if (*nparams >= 2) { + if (params[2] < 0.) { + params[2] = (doublereal) ithresh; + } else { + ithresh = (integer) params[2]; + } + } + if (*nparams >= 3) { + if (params[3] < 0.) { + if (ignore_cwise__) { + params[3] = 0.; + } else { + params[3] = 1.; + } + } else { + ignore_cwise__ = params[3] == 0.; + } + } + if (ref_type__ == 0 || *n_err_bnds__ == 0) { + n_norms__ = 0; + } else if (ignore_cwise__) { + n_norms__ = 1; + } else { + n_norms__ = 2; + } + + rcequ = lsame_(equed, "Y"); + +/* Test input parameters. */ + + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! rcequ && ! lsame_(equed, "N")) { + *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 = -12; + } else if (*ldx < f2cmax(1,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYRFSX", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *nrhs == 0) { + *rcond = 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } + if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.; + } + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.; + } + } + return 0; + } + +/* Default to failure. */ + + *rcond = 0.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 1.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } + if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.; + } + } + +/* Compute the norm of A and the reciprocal of the condition */ +/* number of A. */ + + *(unsigned char *)norm = 'I'; + anorm = dlansy_(norm, uplo, n, &a[a_offset], lda, &work[1]); + dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], + &iwork[1], info); + +/* Perform refinement on each right-hand side */ + + if (ref_type__ != 0) { + prec_type__ = ilaprec_("E"); + dla_syrfsx_extended_(&prec_type__, uplo, n, nrhs, &a[a_offset], lda, + &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset], + ldb, &x[x_offset], ldx, &berr[1], &n_norms__, & + err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n << + 1) + 1], &work[1], rcond, &ithresh, &rthresh, & + unstable_thresh__, &ignore_cwise__, info); + } +/* Computing MAX */ + d__1 = 10., d__2 = sqrt((doublereal) (*n)); + err_lbnd__ = f2cmax(d__1,d__2) * dlamch_("Epsilon"); + if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { + +/* Compute scaled normwise condition number cond(A*C). */ + + if (rcequ) { + rcond_tmp__ = dla_syrcond_(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &c_n1, &s[1], info, &work[1], + &iwork[1]); + } else { + rcond_tmp__ = dla_syrcond_(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &c__0, &s[1], info, &work[1], + &iwork[1]); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 + << 1)] > 1.) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_norm__[j + err_bnds_norm_dim1] = 0.; + if (*info <= *n) { + *info = *n + j; + } + } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < + err_lbnd__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; + } + } + } + if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { + +/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ +/* each right-hand side using the current solution as an estimate of */ +/* the true solution. If the componentwise error estimate is too */ +/* large, then the solution is a lousy estimate of truth and the */ +/* estimated RCOND may be too optimistic. To avoid misleading users, */ +/* the inverse condition number is set to 0.0 when the estimated */ +/* cwise error is at least CWISE_WRONG. */ + + cwise_wrong__ = sqrt(dlamch_("Epsilon")); + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + cwise_wrong__) { + rcond_tmp__ = dla_syrcond_(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1], + info, &work[1], &iwork[1]); + } else { + rcond_tmp__ = 0.; + } + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 + << 1)] > 1.) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 0.; + if (! ignore_cwise__ && *info < *n + j) { + *info = *n + j; + } + } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + err_lbnd__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; + } + } + } + + return 0; + +/* End of DSYRFSX */ + +} /* dsyrfsx_ */ + diff --git a/lapack-netlib/SRC/dsysv.c b/lapack-netlib/SRC/dsysv.c new file mode 100644 index 000000000..b372f436a --- /dev/null +++ b/lapack-netlib/SRC/dsysv.c @@ -0,0 +1,672 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYSV computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, LWORK, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYSV computes the solution to a real system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > The diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the block diagonal matrix D and the */ +/* > multipliers used to obtain the factor U or L from the */ +/* > factorization A = U*D*U**T or A = L*D*L**T as computed by */ +/* > DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, as */ +/* > determined by DSYTRF. 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 DOUBLE PRECISION 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] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= 1, and for best performance */ +/* > LWORK >= f2cmax(1,N*NB), where NB is the optimal blocksize for */ +/* > DSYTRF. */ +/* > for LWORK < N, TRS will be done with Level BLAS 2 */ +/* > for LWORK >= N, TRS will be done with Level BLAS 3 */ +/* > */ +/* > 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, 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 doubleSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dsysv_(char *uplo, integer *n, integer *nrhs, doublereal + *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, + doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dsytrf_( + char *, integer *, doublereal *, integer *, integer *, doublereal + *, integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int dsytrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *), dsytrs2_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* 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; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*lwork < 1 && ! lquery) { + *info = -10; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + dsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &c_n1, + info); + lwkopt = (integer) work[1]; + } + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSV ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + dsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + if (*lwork < *n) { + +/* Solve with TRS ( Use Level BLAS 2) */ + + dsytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, info); + + } else { + +/* Solve with TRS2 ( Use Level BLAS 3) */ + + dsytrs2_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, &work[1], info); + + } + + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYSV */ + +} /* dsysv_ */ + diff --git a/lapack-netlib/SRC/dsysv_aa.c b/lapack-netlib/SRC/dsysv_aa.c new file mode 100644 index 000000000..7e792a48e --- /dev/null +++ b/lapack-netlib/SRC/dsysv_aa.c @@ -0,0 +1,652 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSV_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LDB, LWORK, INFO */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYSV computes the solution to a real system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > Aasen's algorithm is used to factor A as */ +/* > A = U**T * T * U, if UPLO = 'U', or */ +/* > A = L * T * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is symmetric tridiagonal. 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the tridiagonal matrix T and the */ +/* > multipliers used to obtain the factor U or L from the */ +/* > factorization A = U**T*T*U or A = L*T*L**T as computed by */ +/* > DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[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[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= MAX(1,2*N,3*N-2), and for */ +/* > the best performance, LWORK >= MAX(1,N*NB), where NB is */ +/* > the optimal blocksize for DSYTRF_AA. */ +/* > */ +/* > 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, 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 November 2017 */ + +/* > \ingroup doubleSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dsysv_aa_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * + ldb, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + integer lwkopt_sytrf__, lwkopt_sytrs__; + extern /* Subroutine */ int dsytrf_aa_(char *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *), + dsytrs_aa_(char *, integer *, integer *, doublereal *, integer * + , integer *, doublereal *, integer *, doublereal *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + 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; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = *n << 1, i__2 = *n * 3 - 2; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -10; + } + } + + if (*info == 0) { + dsytrf_aa_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &c_n1, + info); + lwkopt_sytrf__ = (integer) work[1]; + dsytrs_aa_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, &work[1], &c_n1, info); + lwkopt_sytrs__ = (integer) work[1]; + lwkopt = f2cmax(lwkopt_sytrf__,lwkopt_sytrs__); + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSV_AA ", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U**T*T*U or A = L*T*L**T. */ + + dsytrf_aa_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dsytrs_aa_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, &work[1], lwork, info); + + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYSV_AA */ + +} /* dsysv_aa__ */ + diff --git a/lapack-netlib/SRC/dsysv_aa_2stage.c b/lapack-netlib/SRC/dsysv_aa_2stage.c new file mode 100644 index 000000000..5c529b1be --- /dev/null +++ b/lapack-netlib/SRC/dsysv_aa_2stage.c @@ -0,0 +1,681 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices + */ + +/* @generated from SRC/chesv_aa_2stage.f, fortran c -> d, Tue Oct 31 11:22:31 2017 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSV_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSV_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, */ +/* IPIV, IPIV2, B, LDB, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LTB, LDB, LWORK, INFO */ +/* INTEGER IPIV( * ), IPIV2( * ) */ +/* DOUBLE PRECISION A( LDA, * ), TB( * ), B( LDB, *), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYSV_AA_2STAGE computes the solution to a real system of */ +/* > linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > Aasen's 2-stage algorithm is used to factor A as */ +/* > A = U**T * T * U, if UPLO = 'U', or */ +/* > A = L * T * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is symmetric and band. The matrix T is */ +/* > then LU-factored with partial pivoting. The factored form of A */ +/* > is then used to solve the system of equations A * X = B. */ +/* > */ +/* > 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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, 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 DOUBLE PRECISION 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[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION 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 doubleSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dsysv_aa_2stage_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *tb, integer *ltb, integer * + ipiv, integer *ipiv2, doublereal *b, integer *ldb, doublereal *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int dsytrf_aa_2stage_(char *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *, + integer *, doublereal *, integer *, integer *), + dsytrs_aa_2stage_(char *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, + doublereal *, integer *, integer *); + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical tquery, wquery; + + +/* -- 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; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --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 (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ltb < *n << 2 && ! tquery) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -11; + } else if (*lwork < *n && ! wquery) { + *info = -13; + } + + if (*info == 0) { + dsytrf_aa_2stage_(uplo, n, &a[a_offset], lda, &tb[1], &c_n1, &ipiv[1] + , &ipiv2[1], &work[1], &c_n1, info); + lwkopt = (integer) work[1]; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSV_AA_2STAGE", &i__1, (ftnlen)15); + return 0; + } else if (wquery || tquery) { + return 0; + } + + +/* Compute the factorization A = U**T*T*U or A = L*T*L**T. */ + + dsytrf_aa_2stage_(uplo, n, &a[a_offset], lda, &tb[1], ltb, &ipiv[1], & + ipiv2[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dsytrs_aa_2stage_(uplo, n, nrhs, &a[a_offset], lda, &tb[1], ltb, & + ipiv[1], &ipiv2[1], &b[b_offset], ldb, info); + + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYSV_AA_2STAGE */ + +} /* dsysv_aa_2stage__ */ + diff --git a/lapack-netlib/SRC/dsysv_rk.c b/lapack-netlib/SRC/dsysv_rk.c new file mode 100644 index 000000000..1c10448ed --- /dev/null +++ b/lapack-netlib/SRC/dsysv_rk.c @@ -0,0 +1,718 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSV_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, LWORK, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > DSYSV_RK computes the solution to a real system of linear */ +/* > equations A * X = B, where A is an N-by-N symmetric matrix */ +/* > and X and B are N-by-NRHS matrices. */ +/* > */ +/* > The bounded Bunch-Kaufman (rook) diagonal pivoting method is used */ +/* > to factor A as */ +/* > A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or */ +/* > A = P*L*D*(L**T)*(P**T), if UPLO = 'L', */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > DSYTRF_RK is called to compute the factorization of a real */ +/* > symmetric matrix. The factored form of A is then used to solve */ +/* > the system of equations A * X = B by calling BLAS3 routine DSYTRS_3. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. */ +/* > If UPLO = 'U': the leading N-by-N upper triangular part */ +/* > of A contains the upper triangular part of the matrix A, */ +/* > and the strictly lower triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > If UPLO = 'L': the leading N-by-N lower triangular part */ +/* > of A contains the lower triangular part of the matrix A, */ +/* > and the strictly upper triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > On exit, if INFO = 0, diagonal of the block diagonal */ +/* > matrix D and factors U or L as computed by DSYTRF_RK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > For more info see the description of DSYTRF_RK routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, contains the output computed by the factorization */ +/* > routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > */ +/* > For more info see the description of DSYTRF_RK routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, */ +/* > as determined by DSYTRF_RK. */ +/* > */ +/* > For more info see the description of DSYTRF_RK routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension ( MAX(1,LWORK) ). */ +/* > Work array used in the factorization stage. */ +/* > 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 */ +/* > of factorization stage LWORK >= f2cmax(1,N*NB), where NB is */ +/* > the optimal blocksize for DSYTRF_RK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; */ +/* > the routine only calculates the optimal size of the WORK */ +/* > array for factorization stage, 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 doubleSYsolve */ + +/* > \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 dsysv_rk_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *e, integer *ipiv, doublereal + *b, integer *ldb, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int dsytrs_3_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dsytrf_rk_(char *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- 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 */ + 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; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*lwork < 1 && ! lquery) { + *info = -11; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + dsytrf_rk_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], + &c_n1, info); + lwkopt = (integer) work[1]; + } + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSV_RK ", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = P*U*D*(U**T)*(P**T) or */ +/* A = P*U*D*(U**T)*(P**T). */ + + dsytrf_rk_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], lwork, + info); + + if (*info == 0) { + +/* Solve the system A*X = B with BLAS3 solver, overwriting B with X. */ + + dsytrs_3_(uplo, n, nrhs, &a[a_offset], lda, &e[1], &ipiv[1], &b[ + b_offset], ldb, info); + + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYSV_RK */ + +} /* dsysv_rk__ */ + diff --git a/lapack-netlib/SRC/dsysv_rook.c b/lapack-netlib/SRC/dsysv_rook.c new file mode 100644 index 000000000..305fb2722 --- /dev/null +++ b/lapack-netlib/SRC/dsysv_rook.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 DSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSV_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, LWORK, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYSV_ROOK computes the solution to a real system of linear */ +/* > equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > The diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > DSYTRF_ROOK is called to compute the factorization of a real */ +/* > symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal */ +/* > pivoting method. */ +/* > */ +/* > The factored form of A is then used to solve the system */ +/* > of equations A * X = B by calling DSYTRS_ROOK. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the block diagonal matrix D and the */ +/* > multipliers used to obtain the factor U or L from the */ +/* > factorization A = U*D*U**T or A = L*D*L**T as computed by */ +/* > DSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, */ +/* > as determined by DSYTRF_ROOK. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= 1, and for best performance */ +/* > LWORK >= f2cmax(1,N*NB), where NB is the optimal blocksize for */ +/* > DSYTRF_ROOK. */ +/* > */ +/* > TRS will be done with Level 2 BLAS */ +/* > */ +/* > 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, 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 April 2012 */ + +/* > \ingroup doubleSYsolve */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > April 2012, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsysv_rook_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * + ldb, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int dsytrf_rook_(char *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *) + , dsytrs_rook_(char *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- 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 */ + 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; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*lwork < 1 && ! lquery) { + *info = -10; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + dsytrf_rook_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], & + c_n1, info); + lwkopt = (integer) work[1]; + } + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSV_ROOK ", &i__1, (ftnlen)11); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + dsytrf_rook_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + +/* Solve with TRS_ROOK ( Use Level 2 BLAS) */ + + dsytrs_rook_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset] + , ldb, info); + + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYSV_ROOK */ + +} /* dsysv_rook__ */ + diff --git a/lapack-netlib/SRC/dsysvx.c b/lapack-netlib/SRC/dsysvx.c new file mode 100644 index 000000000..402eb0ef0 --- /dev/null +++ b/lapack-netlib/SRC/dsysvx.c @@ -0,0 +1,845 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DSYSVX computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, */ +/* LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER FACT, UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYSVX uses the diagonal pivoting factorization to compute the */ +/* > solution to a real system of linear equations A * X = B, */ +/* > where A is an N-by-N symmetric matrix 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. */ +/* > The form of the factorization is */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > 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, AF and IPIV contain the factored form of */ +/* > A. AF and IPIV will not be modified. */ +/* > = 'N': The matrix A will be copied to AF 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular part */ +/* > of the matrix A, and the strictly lower triangular part of A */ +/* > is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of A contains the lower triangular part of */ +/* > the matrix A, and the strictly upper triangular part of A is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AF */ +/* > \verbatim */ +/* > AF is DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > If FACT = 'F', then AF 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**T or A = L*D*L**T as computed by DSYTRF. */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**T or A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \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 DSYTRF. */ +/* > 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 DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= f2cmax(1,3*N), and for best */ +/* > performance, when FACT = 'N', LWORK >= f2cmax(1,3*N,N*NB), where */ +/* > NB is the optimal blocksize for DSYTRF. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \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 doubleSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dsysvx_(char *fact, char *uplo, integer *n, integer * + nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, + integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer * + ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, + doublereal *work, integer *lwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + doublereal anorm; + integer nb; + extern doublereal dlamch_(char *); + logical nofact; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dsycon_(char *, integer *, doublereal *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *), dsyrfs_(char *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, integer *), + dsytrf_(char *, integer *, doublereal *, integer *, integer *, + doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int dsytrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, 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 */ + 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; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + lquery = *lwork == -1; + 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 (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -11; + } else if (*ldx < f2cmax(1,*n)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -18; + } + } + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3; + lwkopt = f2cmax(i__1,i__2); + if (nofact) { + nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * nb; + lwkopt = f2cmax(i__1,i__2); + } + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSVX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + + if (nofact) { + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork, + info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], + &iwork[1], info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &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. */ + + dsyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], + &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] + , &iwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYSVX */ + +} /* dsysvx_ */ + diff --git a/lapack-netlib/SRC/dsysvxx.c b/lapack-netlib/SRC/dsysvxx.c new file mode 100644 index 000000000..8e16912af --- /dev/null +++ b/lapack-netlib/SRC/dsysvxx.c @@ -0,0 +1,1124 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYSVXX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSVXX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, */ +/* EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, */ +/* N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, */ +/* NPARAMS, PARAMS, WORK, IWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, */ +/* $ N_ERR_BNDS */ +/* DOUBLE PRECISION RCOND, RPVGRW */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ X( LDX, * ), WORK( * ) */ +/* DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYSVXX uses the diagonal pivoting factorization to compute the */ +/* > solution to a double precision system of linear equations A * X = B, where A */ +/* > is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. */ +/* > */ +/* > If requested, both normwise and maximum componentwise error bounds */ +/* > are returned. DSYSVXX will return a solution with a tiny */ +/* > guaranteed error (O(eps) where eps is the working machine */ +/* > precision) unless the matrix is very ill-conditioned, in which */ +/* > case a warning is returned. Relevant condition numbers also are */ +/* > calculated and returned. */ +/* > */ +/* > DSYSVXX accepts user-provided factorizations and equilibration */ +/* > factors; see the definitions of the FACT and EQUED options. */ +/* > Solving with refinement and using a factorization from a previous */ +/* > DSYSVXX call will also produce a solution with either O(eps) */ +/* > errors or warnings, but we cannot make that claim for general */ +/* > user-provided factorizations and equilibration factors if they */ +/* > differ from what DSYSVXX would itself produce. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */ +/* > the system: */ +/* > */ +/* > diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */ +/* > */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ +/* > the matrix A (after equilibration if FACT = 'E') as */ +/* > */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > 3. 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 (see */ +/* > argument RCOND). If the reciprocal of the condition number is */ +/* > less than machine precision, the routine still goes on to solve */ +/* > for X and compute error bounds as described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ +/* > the routine will use iterative refinement to try to get a small */ +/* > error and error bounds. Refinement calculates the residual to at */ +/* > least twice the working precision. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(R) so that it solves the original system before */ +/* > equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > Some optional parameters are bundled in the PARAMS array. These */ +/* > settings determine how refinement is performed, but often the */ +/* > defaults are acceptable. If the defaults are acceptable, users */ +/* > can pass NPARAMS = 0 which prevents the source code from accessing */ +/* > the PARAMS argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AF and IPIV contain the factored form of A. */ +/* > If EQUED is not 'N', the matrix A has been */ +/* > equilibrated with scaling factors given by S. */ +/* > A, AF, and IPIV are not modified. */ +/* > = 'N': The matrix A will be copied to AF and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AF and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular */ +/* > part of the matrix A, and the strictly lower triangular */ +/* > part of A is not referenced. If UPLO = 'L', the leading */ +/* > N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* > diag(S)*A*diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AF */ +/* > \verbatim */ +/* > AF is DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > If FACT = 'F', then AF 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**T or A = L*D*L**T as computed by DSYTRF. */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L from the factorization A = */ +/* > U*D*U**T or A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \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 DSYTRF. 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 DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'Y': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(S) * A * diag(S). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. If EQUED = 'Y', A is multiplied on */ +/* > the left and right by diag(S). S is an input argument if FACT = */ +/* > 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ +/* > = 'Y', each element of S must be positive. If S is output, each */ +/* > element of S is a power of the radix. If S is input, each element */ +/* > of S should be a power of the radix to ensure a reliable solution */ +/* > and error estimates. Scaling by powers of the radix does not cause */ +/* > rounding errors unless the result underflows or overflows. */ +/* > Rounding errors during scaling lead to refining with a matrix that */ +/* > is not equivalent to the input matrix, producing error estimates */ +/* > that may not be reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, */ +/* > if EQUED = 'N', B is not modified; */ +/* > if EQUED = 'Y', B is overwritten by diag(S)*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 DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X to the original */ +/* > system of equations. Note that A and B are modified on exit if */ +/* > EQUED .ne. 'N', and the solution to the equilibrated system is */ +/* > inv(diag(S))*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 */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RPVGRW */ +/* > \verbatim */ +/* > RPVGRW is DOUBLE PRECISION */ +/* > Reciprocal pivot growth. On exit, this contains the reciprocal */ +/* > pivot growth factor norm(A)/norm(U). The "f2cmax absolute element" */ +/* > norm is used. If this is much less than 1, then the stability of */ +/* > the LU factorization of the (equilibrated) matrix A could be poor. */ +/* > This also means that the solution X, estimated condition numbers, */ +/* > and error bounds could be unreliable. If factorization fails with */ +/* > 0 for the leading INFO columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > Componentwise relative backward error. This is the */ +/* > componentwise relative backward error of each solution vector X(j) */ +/* > (i.e., the smallest relative change in any element of A or B that */ +/* > makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_ERR_BNDS */ +/* > \verbatim */ +/* > N_ERR_BNDS is INTEGER */ +/* > Number of error bounds to return for each right hand side */ +/* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* > ERR_BNDS_COMP below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NPARAMS */ +/* > \verbatim */ +/* > NPARAMS is INTEGER */ +/* > Specifies the number of parameters set in PARAMS. If <= 0, the */ +/* > PARAMS array is never referenced and default values are used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PARAMS */ +/* > \verbatim */ +/* > PARAMS is DOUBLE PRECISION array, dimension (NPARAMS) */ +/* > Specifies algorithm parameters. If an entry is < 0.0, then */ +/* > that entry will be filled with default value used for that */ +/* > parameter. Only positions up to NPARAMS are accessed; defaults */ +/* > are used for higher-numbered parameters. */ +/* > */ +/* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* > refinement or not. */ +/* > Default: 1.0D+0 */ +/* > = 0.0: No refinement is performed, and no error bounds are */ +/* > computed. */ +/* > = 1.0: Use the extra-precise refinement algorithm. */ +/* > (other values are reserved for future use) */ +/* > */ +/* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* > computations allowed for refinement. */ +/* > Default: 10 */ +/* > Aggressive: Set to 100 to permit convergence using approximate */ +/* > factorizations or factorizations other than LU. If */ +/* > the factorization uses a technique other than */ +/* > Gaussian elimination, the guarantees in */ +/* > err_bnds_norm and err_bnds_comp may no longer be */ +/* > trustworthy. */ +/* > */ +/* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* > will attempt to find a solution with small componentwise */ +/* > relative error in the double-precision algorithm. Positive */ +/* > is true, 0.0 is false. */ +/* > Default: 1.0 (attempt componentwise convergence) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. The solution to every right-hand side is */ +/* > guaranteed. */ +/* > < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly singular, so */ +/* > the solution and error bounds could not be computed. RCOND = 0 */ +/* > is returned. */ +/* > = N+J: The solution corresponding to the Jth right-hand side is */ +/* > not guaranteed. The solutions corresponding to other right- */ +/* > hand sides K with K > J may not be guaranteed as well, but */ +/* > only the first such right-hand side is reported. If a small */ +/* > componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* > the Jth right-hand side is the first with a normwise error */ +/* > bound that is not guaranteed (the smallest J such */ +/* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* > the Jth right-hand side is the first with either a normwise or */ +/* > componentwise error bound that is not guaranteed (the smallest */ +/* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* > about all of the right-hand sides check ERR_BNDS_NORM or */ +/* > ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dsysvxx_(char *fact, char *uplo, integer *n, integer * + nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, + integer *ipiv, char *equed, doublereal *s, doublereal *b, integer * + ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal * + rpvgrw, doublereal *berr, integer *n_err_bnds__, doublereal * + err_bnds_norm__, doublereal *err_bnds_comp__, integer *nparams, + doublereal *params, doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + doublereal d__1, d__2; + + /* Local variables */ + doublereal amax, smin, smax; + integer j; + extern doublereal dla_syrpvgrw_(char *, integer *, integer *, doublereal + *, integer *, doublereal *, integer *, integer *, doublereal *); + extern logical lsame_(char *, char *); + doublereal scond; + logical equil, rcequ; + extern doublereal dlamch_(char *); + logical nofact; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer infequ; + extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, char *); + doublereal smlnum; + extern /* Subroutine */ int dsytrf_(char *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *), + dlascl2_(integer *, integer *, doublereal *, doublereal *, + integer *), dsytrs_(char *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *), + dsyequb_(char *, integer *, doublereal *, integer *, doublereal * + , doublereal *, doublereal *, doublereal *, integer *), + dsyrfsx_(char *, char *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ================================================================== */ + + + /* Parameter adjustments */ + 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; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = FALSE_; + } else { + rcequ = lsame_(equed, "Y"); + } + +/* Default is failure. If an input parameter is wrong or */ +/* factorization fails, make everything look horrible. Only the */ +/* pivot growth is set here, the rest is initialized in DSYRFSX. */ + + *rpvgrw = 0.; + +/* Test the input parameters. PARAMS is not tested until DSYRFSX. */ + + if (! nofact && ! equil && ! 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 (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -10; + } else { + if (rcequ) { + smin = bignum; + smax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = smin, d__2 = s[j]; + smin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[j]; + smax = f2cmax(d__1,d__2); +/* L10: */ + } + if (smin <= 0.) { + *info = -11; + } else if (*n > 0) { + scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + } else { + scond = 1.; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldx < f2cmax(1,*n)) { + *info = -15; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSVXX", &i__1, (ftnlen)7); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dsyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], & + infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + dlascl2_(n, nrhs, &s[1], &b[b_offset], ldb); + } + + if (nofact || equil) { + +/* Compute the LDL^T or UDU^T factorization of A. */ + + dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + i__1 = f2cmax(1,*n) * 5; + dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1, + info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Pivot in column INFO is exactly 0 */ +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + if (*n > 0) { + *rpvgrw = dla_syrpvgrw_(uplo, n, info, &a[a_offset], lda, & + af[af_offset], ldaf, &ipiv[1], &work[1]); + } + return 0; + } + } + +/* Compute the reciprocal pivot growth factor RPVGRW. */ + + if (*n > 0) { + *rpvgrw = dla_syrpvgrw_(uplo, n, info, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &work[1]); + } + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, + info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dsyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, & + ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, & + berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], & + err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[ + 1], &iwork[1], info); + +/* Scale solutions. */ + + if (rcequ) { + dlascl2_(n, nrhs, &s[1], &x[x_offset], ldx); + } + + return 0; + +/* End of DSYSVXX */ + +} /* dsysvxx_ */ + diff --git a/lapack-netlib/SRC/dsyswapr.c b/lapack-netlib/SRC/dsyswapr.c new file mode 100644 index 000000000..39f8b1d8d --- /dev/null +++ b/lapack-netlib/SRC/dsyswapr.c @@ -0,0 +1,593 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYSWAPR applies an elementary permutation on the rows and columns of a symmetric matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYSWAPR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) */ + +/* CHARACTER UPLO */ +/* INTEGER I1, I2, LDA, N */ +/* DOUBLE PRECISION A( LDA, N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYSWAPR applies an elementary permutation on the rows and the columns of */ +/* > a symmetric matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the NB diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by DSYTRF. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix. If UPLO = 'U', the upper triangular part of the */ +/* > inverse is formed and the part of A below the diagonal is not */ +/* > referenced; if UPLO = 'L' the lower triangular part of the */ +/* > inverse is formed and the part of A above the diagonal is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I1 */ +/* > \verbatim */ +/* > I1 is INTEGER */ +/* > Index of the first row to swap */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I2 */ +/* > \verbatim */ +/* > I2 is INTEGER */ +/* > Index of the second row to swap */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dsyswapr_(char *uplo, integer *n, doublereal *a, integer + *lda, integer *i1, integer *i2) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + doublereal tmp; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + upper = lsame_(uplo, "U"); + if (upper) { + +/* UPPER */ +/* first swap */ +/* - swap column I1 and I2 from I1 to I1-1 */ + i__1 = *i1 - 1; + dswap_(&i__1, &a[*i1 * a_dim1 + 1], &c__1, &a[*i2 * a_dim1 + 1], & + c__1); + +/* second swap : */ +/* - swap A(I1,I1) and A(I2,I2) */ +/* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 */ + tmp = a[*i1 + *i1 * a_dim1]; + a[*i1 + *i1 * a_dim1] = a[*i2 + *i2 * a_dim1]; + a[*i2 + *i2 * a_dim1] = tmp; + + i__1 = *i2 - *i1 - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = a[*i1 + (*i1 + i__) * a_dim1]; + a[*i1 + (*i1 + i__) * a_dim1] = a[*i1 + i__ + *i2 * a_dim1]; + a[*i1 + i__ + *i2 * a_dim1] = tmp; + } + +/* third swap */ +/* - swap row I1 and I2 from I2+1 to N */ + i__1 = *n; + for (i__ = *i2 + 1; i__ <= i__1; ++i__) { + tmp = a[*i1 + i__ * a_dim1]; + a[*i1 + i__ * a_dim1] = a[*i2 + i__ * a_dim1]; + a[*i2 + i__ * a_dim1] = tmp; + } + + } else { + +/* LOWER */ +/* first swap */ +/* - swap row I1 and I2 from I1 to I1-1 */ + i__1 = *i1 - 1; + dswap_(&i__1, &a[*i1 + a_dim1], lda, &a[*i2 + a_dim1], lda); + +/* second swap : */ +/* - swap A(I1,I1) and A(I2,I2) */ +/* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 */ + tmp = a[*i1 + *i1 * a_dim1]; + a[*i1 + *i1 * a_dim1] = a[*i2 + *i2 * a_dim1]; + a[*i2 + *i2 * a_dim1] = tmp; + + i__1 = *i2 - *i1 - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = a[*i1 + i__ + *i1 * a_dim1]; + a[*i1 + i__ + *i1 * a_dim1] = a[*i2 + (*i1 + i__) * a_dim1]; + a[*i2 + (*i1 + i__) * a_dim1] = tmp; + } + +/* third swap */ +/* - swap col I1 and I2 from I2+1 to N */ + i__1 = *n; + for (i__ = *i2 + 1; i__ <= i__1; ++i__) { + tmp = a[i__ + *i1 * a_dim1]; + a[i__ + *i1 * a_dim1] = a[i__ + *i2 * a_dim1]; + a[i__ + *i2 * a_dim1] = tmp; + } + + } + return 0; +} /* dsyswapr_ */ + diff --git a/lapack-netlib/SRC/dsytd2.c b/lapack-netlib/SRC/dsytd2.c new file mode 100644 index 000000000..d99c56620 --- /dev/null +++ b/lapack-netlib/SRC/dsytd2.c @@ -0,0 +1,740 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarit +y transformation (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTD2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */ +/* > form T by an orthogonal similarity transformation: Q**T * A * Q = T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, 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 orthogonal */ +/* > 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 orthogonal matrix Q as a product */ +/* > of elementary reflectors. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \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 DOUBLE PRECISION 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 doubleSYcomputational */ + +/* > \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**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ +/* > A(1:i-1,i+1), and tau 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**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ +/* > and tau in TAU(i). */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples */ +/* > with n = 5: */ +/* > */ +/* > if UPLO = 'U': if UPLO = 'L': */ +/* > */ +/* > ( d e v2 v3 v4 ) ( d ) */ +/* > ( d e v3 v4 ) ( e d ) */ +/* > ( d e v4 ) ( v1 e d ) */ +/* > ( d e ) ( v1 v2 e d ) */ +/* > ( d ) ( v1 v2 v3 e d ) */ +/* > */ +/* > where d and e denote diagonal and off-diagonal elements of T, and vi */ +/* > denotes an element of the vector defining H(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer * + lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal taui; + extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer i__; + doublereal alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dlarfg_(integer *, doublereal *, + doublereal *, integer *, doublereal *), xerbla_(char *, integer *, ftnlen + ); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + --e; + --tau; + + /* 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_("DSYTD2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + if (upper) { + +/* Reduce the upper triangle of A */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) = I - tau * v * v**T */ +/* to annihilate A(1:i-1,i+1) */ + + dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 + + 1], &c__1, &taui); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(1:i,1:i) */ + + a[i__ + (i__ + 1) * a_dim1] = 1.; + +/* Compute x := tau * A * v storing x in TAU(1:i) */ + + dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * + a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1); + +/* Compute w := x - 1/2 * tau * (x**T * v) * v */ + + alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) + * a_dim1 + 1], &c__1); + daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ + 1], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w**T - w * v**T */ + + dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, + &tau[1], &c__1, &a[a_offset], lda); + + a[i__ + (i__ + 1) * a_dim1] = e[i__]; + } + d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; + tau[i__] = taui; +/* L10: */ + } + d__[1] = a[a_dim1 + 1]; + } else { + +/* Reduce the lower triangle of A */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) = I - tau * v * v**T */ +/* to annihilate A(i+2:n,i) */ + + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[f2cmin(i__3,*n) + i__ * + a_dim1], &c__1, &taui); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ + + a[i__ + 1 + i__ * a_dim1] = 1.; + +/* Compute x := tau * A * v storing y in TAU(i:n-1) */ + + i__2 = *n - i__; + dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ + i__], &c__1); + +/* Compute w := x - 1/2 * tau * (x**T * v) * v */ + + i__2 = *n - i__; + alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + + 1 + i__ * a_dim1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w**T - w * v**T */ + + i__2 = *n - i__; + dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, + &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda); + + a[i__ + 1 + i__ * a_dim1] = e[i__]; + } + d__[i__] = a[i__ + i__ * a_dim1]; + tau[i__] = taui; +/* L20: */ + } + d__[*n] = a[*n + *n * a_dim1]; + } + + return 0; + +/* End of DSYTD2 */ + +} /* dsytd2_ */ + diff --git a/lapack-netlib/SRC/dsytf2.c b/lapack-netlib/SRC/dsytf2.c new file mode 100644 index 000000000..df4423ef6 --- /dev/null +++ b/lapack-netlib/SRC/dsytf2.c @@ -0,0 +1,1052 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal piv +oting method (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTF2 computes the factorization of a real symmetric matrix A using */ +/* > the Bunch-Kaufman diagonal pivoting method: */ +/* > */ +/* > 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, U**T is the transpose of U, and D is symmetric and */ +/* > block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = 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': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = IPIV(k+1) < 0, then rows and columns */ +/* > k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) */ +/* > is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*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 */ +/* > */ +/* > 09-29-06 - patch from */ +/* > Bobby Cheng, MathWorks */ +/* > */ +/* > Replace l.204 and l.372 */ +/* > IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */ +/* > by */ +/* > IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */ +/* > */ +/* > 01-01-96 - Based on modifications by */ +/* > J. Lewis, Boeing Computer Services Company */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ +/* > 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */ +/* > Company */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytf2_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer imax, jmax; + extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + integer i__, j, k; + doublereal t, alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer kstep; + logical upper; + doublereal r1, d11, d12, d21, d22; + integer kk, kp; + doublereal absakk, wk; + extern integer idamax_(integer *, doublereal *, integer *); + extern logical disnan_(doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal colmax, rowmax, 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + + /* 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_("DSYTF2", &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**T 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; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L70; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { + +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = k - imax; + jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1], + lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + if (imax > 1) { + i__1 = imax - 1; + jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], + abs(d__1)); + rowmax = f2cmax(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = a[imax + imax * a_dim1], 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 (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + i__1 = kp - 1; + dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], + &c__1); + i__1 = kk - kp - 1; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k - 1 + k * a_dim1]; + a[k - 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + } + +/* 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)**T = A - W(k)*1/D(k)*W(k)**T */ + + r1 = 1. / a[k + k * a_dim1]; + i__1 = k - 1; + d__1 = -r1; + dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[ + a_offset], lda); + +/* Store U(k) in column k */ + + i__1 = k - 1; + dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &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) )**T */ +/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T */ + + if (k > 2) { + + d12 = a[k - 1 + k * a_dim1]; + d22 = a[k - 1 + (k - 1) * a_dim1] / d12; + d11 = a[k + k * a_dim1] / d12; + t = 1. / (d11 * d22 - 1.); + d12 = t / d12; + + for (j = k - 2; j >= 1; --j) { + wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k + * a_dim1]); + wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]); + for (i__ = j; i__ >= 1; --i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] * wk - a[i__ + (k - 1) * + a_dim1] * wkm1; +/* L20: */ + } + a[j + k * a_dim1] = wk; + a[j + (k - 1) * a_dim1] = wkm1; +/* L30: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + + } 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 */ +/* 1 or 2 */ + + k = 1; +L40: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L70; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { + +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = imax - k; + jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1], + &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], + abs(d__1)); + rowmax = f2cmax(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = a[imax + imax * a_dim1], 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 (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; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - kk - 1; + dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k + 1 + k * a_dim1]; + a[k + 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + } + +/* 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)**T = A - W(k)*(1/D(k))*W(k)**T */ + + d11 = 1. / a[k + k * a_dim1]; + i__1 = *n - k; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, & + a[k + 1 + (k + 1) * a_dim1], lda); + +/* Store L(k) in column K */ + + i__1 = *n - k; + dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + +/* 2-by-2 pivot block D(k) */ + + if (k < *n - 1) { + +/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ + +/* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))**T */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th */ +/* columns of L */ + + d21 = a[k + 1 + k * a_dim1]; + d11 = a[k + 1 + (k + 1) * a_dim1] / d21; + d22 = a[k + k * a_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + + wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]); + wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k + * a_dim1]); + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] * wk - a[i__ + (k + 1) * + a_dim1] * wkp1; +/* L50: */ + } + + a[j + k * a_dim1] = wk; + a[j + (k + 1) * a_dim1] = wkp1; + +/* L60: */ + } + } + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L40; + + } + +L70: + + return 0; + +/* End of DSYTF2 */ + +} /* dsytf2_ */ + diff --git a/lapack-netlib/SRC/dsytf2_rk.c b/lapack-netlib/SRC/dsytf2_rk.c new file mode 100644 index 000000000..3e8e71747 --- /dev/null +++ b/lapack-netlib/SRC/dsytf2_rk.c @@ -0,0 +1,1418 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bu +nch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTF2_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E ( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > DSYTF2_RK computes the factorization of a real symmetric matrix A */ +/* > using the bounded Bunch-Kaufman (rook) diagonal pivoting method: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > For more information see Further Details section. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. */ +/* > If UPLO = 'U': the leading N-by-N upper triangular part */ +/* > of A contains the upper triangular part of the matrix A, */ +/* > and the strictly lower triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > If UPLO = 'L': the leading N-by-N lower triangular part */ +/* > of A contains the lower triangular part of the matrix A, */ +/* > and the strictly upper triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > On exit, contains: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > IPIV describes the permutation matrix P in the factorization */ +/* > of matrix A as follows. The absolute value of IPIV(k) */ +/* > represents the index of row and column that were */ +/* > interchanged with the k-th row and column. The value of UPLO */ +/* > describes the order in which the interchanges were applied. */ +/* > Also, the sign of IPIV represents the block structure of */ +/* > the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 */ +/* > diagonal blocks which correspond to 1 or 2 interchanges */ +/* > at each factorization step. For more info see Further */ +/* > Details section. */ +/* > */ +/* > If UPLO = 'U', */ +/* > ( in factorization order, k decreases from N to 1 ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the matrix A(1:N,1:N); */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k-1) < 0 means: */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k-1) != k-1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k-1) = k-1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b), always ABS( IPIV(k) ) <= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > */ +/* > If UPLO = 'L', */ +/* > ( in factorization order, k increases from 1 to N ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the matrix A(1:N,1:N). */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k+1) < 0 means: */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k+1) != k+1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k+1) = k+1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b), always ABS( IPIV(k) ) >= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > < 0: If INFO = -k, the k-th argument had an illegal value */ +/* > */ +/* > > 0: If INFO = k, the matrix A is singular, because: */ +/* > If UPLO = 'U': column k in the upper */ +/* > triangular part of A contains all zeros. */ +/* > If UPLO = 'L': column k in the lower */ +/* > triangular part of A contains all zeros. */ +/* > */ +/* > Therefore D(k,k) is exactly zero, and superdiagonal */ +/* > elements of column k of U (or subdiagonal elements of */ +/* > column k of L ) are all zeros. The factorization has */ +/* > been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if */ +/* > it is used to solve a system of equations. */ +/* > */ +/* > NOTE: INFO only stores the first occurrence of */ +/* > a singularity, any subsequent occurrence of singularity */ +/* > is not stored in INFO even though the factorization */ +/* > always completes. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > TODO: put further details */ +/* > \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 */ +/* > */ +/* > 01-01-96 - Based on modifications by */ +/* > J. Lewis, Boeing Computer Services Company */ +/* > A. Petitet, Computer Science Dept., */ +/* > Univ. of Tenn., Knoxville abd , USA */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytf2_rk_(char *uplo, integer *n, doublereal *a, + integer *lda, doublereal *e, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + logical done; + integer imax, jmax; + extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + integer i__, j, k, p; + doublereal t, alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal dtemp, sfmin; + integer itemp; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer kstep; + logical upper; + doublereal d11, d12, d21, d22; + integer ii, kk; + extern doublereal dlamch_(char *); + integer kp; + doublereal absakk, wk; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal colmax, rowmax, 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + + /* 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_("DSYTF2_RK", &i__1, (ftnlen)9); + return 0; + } + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + +/* Compute machine safe minimum */ + + sfmin = dlamch_("S"); + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* Initialize the first entry of array E, where superdiagonal */ +/* elements of D are stored */ + + e[1] = 0.; + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2 */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L34; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + +/* Set E( K ) to zero */ + + if (k > 1) { + e[k] = 0.; + } + + } else { + +/* Test for interchange */ + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABSAKK.GE.ALPHA*COLMAX */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, */ +/* use 1-by-1 pivot block */ + + kp = k; + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * + a_dim1], lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + } else { + rowmax = 0.; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); + dtemp = (d__1 = a[itemp + imax * a_dim1], abs(d__1)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */ + + if (! ((d__1 = a[imax + imax * a_dim1], abs(d__1)) < alpha * + rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + done = TRUE_; + +/* Equivalent to testing for ROWMAX .EQ. COLMAX, */ +/* used to handle NaN and Inf */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot NOT found, set variables and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* Swap TWO rows and TWO columns */ + +/* First swap */ + + if (kstep == 2 && p != k) { + +/* Interchange rows and column K and P in the leading */ +/* submatrix A(1:k,1:k) if we have a 2-by-2 pivot */ + + if (p > 1) { + i__1 = p - 1; + dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + + 1], &c__1); + } + if (p < k - 1) { + i__1 = k - p - 1; + dswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + + 1) * a_dim1], lda); + } + t = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[p + p * a_dim1]; + a[p + p * a_dim1] = t; + +/* Convert upper triangle of A into U form by applying */ +/* the interchanges in columns k+1:N. */ + + if (k < *n) { + i__1 = *n - k; + dswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k + + 1) * a_dim1], lda); + } + + } + +/* Second swap */ + + kk = k - kstep + 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + if (kp > 1) { + i__1 = kp - 1; + dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (kk > 1 && kp < kk - 1) { + i__1 = kk - kp - 1; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + ( + kp + 1) * a_dim1], lda); + } + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k - 1 + k * a_dim1]; + a[k - 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + +/* Convert upper triangle of A into U form by applying */ +/* the interchanges in columns k+1:N. */ + + if (k < *n) { + i__1 = *n - k; + dswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + + } + +/* 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 */ + + if (k > 1) { + +/* Perform a rank-1 update of A(1:k-1,1:k-1) and */ +/* store U(k) in column k */ + + if ((d__1 = a[k + k * a_dim1], abs(d__1)) >= sfmin) { + +/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ +/* A := A - U(k)*D(k)*U(k)**T */ +/* = A - W(k)*1/D(k)*W(k)**T */ + + d11 = 1. / a[k + k * a_dim1]; + i__1 = k - 1; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, & + a[a_offset], lda); + +/* Store U(k) in column k */ + + i__1 = k - 1; + dscal_(&i__1, &d11, &a[k * a_dim1 + 1], &c__1); + } else { + +/* Store L(k) in column K */ + + d11 = a[k + k * a_dim1]; + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= d11; +/* L16: */ + } + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - U(k)*D(k)*U(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ +/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */ + + i__1 = k - 1; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, & + a[a_offset], lda); + } + +/* Store the superdiagonal element of D in array E */ + + e[k] = 0.; + + } + + } 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) )**T */ +/* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T */ + +/* and store L(k) and L(k+1) in columns k and k+1 */ + + if (k > 2) { + + d12 = a[k - 1 + k * a_dim1]; + d22 = a[k - 1 + (k - 1) * a_dim1] / d12; + d11 = a[k + k * a_dim1] / d12; + t = 1. / (d11 * d22 - 1.); + + for (j = k - 2; j >= 1; --j) { + + wkm1 = t * (d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]); + wk = t * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]); + + for (i__ = j; i__ >= 1; --i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] / d12 * wk - a[i__ + (k - 1) + * a_dim1] / d12 * wkm1; +/* L20: */ + } + +/* Store U(k) and U(k-1) in cols k and k-1 for row J */ + + a[j + k * a_dim1] = wk / d12; + a[j + (k - 1) * a_dim1] = wkm1 / d12; + +/* L30: */ + } + + } + +/* Copy superdiagonal elements of D(K) to E(K) and */ +/* ZERO out superdiagonal entry of A */ + + e[k] = a[k - 1 + k * a_dim1]; + e[k - 1] = 0.; + a[k - 1 + k * a_dim1] = 0.; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L34: + + ; + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* Initialize the unused last entry of the subdiagonal array E. */ + + e[*n] = 0.; + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; +L40: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L64; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + +/* Set E( K ) to zero */ + + if (k < *n) { + e[k] = 0.; + } + + } else { + +/* Test for interchange */ + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABSAKK.GE.ALPHA*COLMAX */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L42: + +/* Begin pivot search loop body */ + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + } else { + rowmax = 0.; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1] + , &c__1); + dtemp = (d__1 = a[itemp + imax * a_dim1], abs(d__1)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */ + + if (! ((d__1 = a[imax + imax * a_dim1], abs(d__1)) < alpha * + rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + done = TRUE_; + +/* Equivalent to testing for ROWMAX .EQ. COLMAX, */ +/* used to handle NaN and Inf */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot NOT found, set variables and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + } + +/* End pivot search loop body */ + + if (! done) { + goto L42; + } + + } + +/* Swap TWO rows and TWO columns */ + +/* First swap */ + + if (kstep == 2 && p != k) { + +/* Interchange rows and column K and P in the trailing */ +/* submatrix A(k:n,k:n) if we have a 2-by-2 pivot */ + + if (p < *n) { + i__1 = *n - p; + dswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p + * a_dim1], &c__1); + } + if (p > k + 1) { + i__1 = p - k - 1; + dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + + 1) * a_dim1], lda); + } + t = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[p + p * a_dim1]; + a[p + p * a_dim1] = t; + +/* Convert lower triangle of A into L form by applying */ +/* the interchanges in columns 1:k-1. */ + + if (k > 1) { + i__1 = k - 1; + dswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + } + + } + +/* Second swap */ + + kk = k + kstep - 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; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (kk < *n && kp > kk + 1) { + i__1 = kp - kk - 1; + dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + ( + kk + 1) * a_dim1], lda); + } + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k + 1 + k * a_dim1]; + a[k + 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + +/* Convert lower triangle of A into L form by applying */ +/* the interchanges in columns 1:k-1. */ + + if (k > 1) { + i__1 = k - 1; + dswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + + } + +/* 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) and */ +/* store L(k) in column k */ + + if ((d__1 = a[k + k * a_dim1], abs(d__1)) >= sfmin) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - L(k)*D(k)*L(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ + + d11 = 1. / a[k + k * a_dim1]; + i__1 = *n - k; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], & + c__1, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Store L(k) in column k */ + + i__1 = *n - k; + dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1); + } else { + +/* Store L(k) in column k */ + + d11 = a[k + k * a_dim1]; + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= d11; +/* L46: */ + } + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - L(k)*D(k)*L(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ +/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */ + + i__1 = *n - k; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], & + c__1, &a[k + 1 + (k + 1) * a_dim1], lda); + } + +/* Store the subdiagonal element of D in array E */ + + e[k] = 0.; + + } + + } 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 */ + + +/* 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) )**T */ +/* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T */ + +/* and store L(k) and L(k+1) in columns k and k+1 */ + + if (k < *n - 1) { + + d21 = a[k + 1 + k * a_dim1]; + d11 = a[k + 1 + (k + 1) * a_dim1] / d21; + d22 = a[k + k * a_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + +/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ + + wk = t * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]); + wkp1 = t * (d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]); + +/* Perform a rank-2 update of A(k+2:n,k+2:n) */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] / d21 * wk - a[i__ + (k + 1) + * a_dim1] / d21 * wkp1; +/* L50: */ + } + +/* Store L(k) and L(k+1) in cols k and k+1 for row J */ + + a[j + k * a_dim1] = wk / d21; + a[j + (k + 1) * a_dim1] = wkp1 / d21; + +/* L60: */ + } + + } + +/* Copy subdiagonal elements of D(K) to E(K) and */ +/* ZERO out subdiagonal entry of A */ + + e[k] = a[k + 1 + k * a_dim1]; + e[k + 1] = 0.; + a[k + 1 + k * a_dim1] = 0.; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L40; + +L64: + + ; + } + + return 0; + +/* End of DSYTF2_RK */ + +} /* dsytf2_rk__ */ + diff --git a/lapack-netlib/SRC/dsytf2_rook.c b/lapack-netlib/SRC/dsytf2_rook.c new file mode 100644 index 000000000..bb60139d9 --- /dev/null +++ b/lapack-netlib/SRC/dsytf2_rook.c @@ -0,0 +1,1274 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded +Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTF2_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTF2_ROOK computes the factorization of a real symmetric matrix A */ +/* > using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: */ +/* > */ +/* > 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, U**T is the transpose of U, and D is symmetric and */ +/* > block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, D(k,k) 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 November 2013 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 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 */ +/* > */ +/* > 01-01-96 - Based on modifications by */ +/* > J. Lewis, Boeing Computer Services Company */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytf2_rook_(char *uplo, integer *n, doublereal *a, + integer *lda, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + logical done; + integer imax, jmax; + extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + integer i__, j, k, p; + doublereal t, alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal dtemp, sfmin; + integer itemp; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer kstep; + logical upper; + doublereal d11, d12, d21, d22; + integer ii, kk; + extern doublereal dlamch_(char *); + integer kp; + doublereal absakk, wk; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal colmax, rowmax, wkm1, wkp1; + + +/* -- 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; + + /* 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_("DSYTF2_ROOK", &i__1, (ftnlen)11); + return 0; + } + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + +/* Compute machine safe minimum */ + + sfmin = dlamch_("S"); + + 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 */ +/* 1 or 2 */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L70; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + +/* Test for interchange */ + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABSAKK.GE.ALPHA*COLMAX */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, */ +/* use 1-by-1 pivot block */ + + kp = k; + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * + a_dim1], lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + } else { + rowmax = 0.; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); + dtemp = (d__1 = a[itemp + imax * a_dim1], abs(d__1)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */ + + if (! ((d__1 = a[imax + imax * a_dim1], abs(d__1)) < alpha * + rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + done = TRUE_; + +/* Equivalent to testing for ROWMAX .EQ. COLMAX, */ +/* used to handle NaN and Inf */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot NOT found, set variables and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* Swap TWO rows and TWO columns */ + +/* First swap */ + + if (kstep == 2 && p != k) { + +/* Interchange rows and column K and P in the leading */ +/* submatrix A(1:k,1:k) if we have a 2-by-2 pivot */ + + if (p > 1) { + i__1 = p - 1; + dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + + 1], &c__1); + } + if (p < k - 1) { + i__1 = k - p - 1; + dswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + + 1) * a_dim1], lda); + } + t = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[p + p * a_dim1]; + a[p + p * a_dim1] = t; + } + +/* Second swap */ + + kk = k - kstep + 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + if (kp > 1) { + i__1 = kp - 1; + dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (kk > 1 && kp < kk - 1) { + i__1 = kk - kp - 1; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + ( + kp + 1) * a_dim1], lda); + } + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k - 1 + k * a_dim1]; + a[k - 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + } + +/* 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 */ + + if (k > 1) { + +/* Perform a rank-1 update of A(1:k-1,1:k-1) and */ +/* store U(k) in column k */ + + if ((d__1 = a[k + k * a_dim1], abs(d__1)) >= sfmin) { + +/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ +/* A := A - U(k)*D(k)*U(k)**T */ +/* = A - W(k)*1/D(k)*W(k)**T */ + + d11 = 1. / a[k + k * a_dim1]; + i__1 = k - 1; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, & + a[a_offset], lda); + +/* Store U(k) in column k */ + + i__1 = k - 1; + dscal_(&i__1, &d11, &a[k * a_dim1 + 1], &c__1); + } else { + +/* Store L(k) in column K */ + + d11 = a[k + k * a_dim1]; + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= d11; +/* L16: */ + } + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - U(k)*D(k)*U(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ +/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */ + + i__1 = k - 1; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, & + a[a_offset], lda); + } + } + + } 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) )**T */ +/* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T */ + +/* and store L(k) and L(k+1) in columns k and k+1 */ + + if (k > 2) { + + d12 = a[k - 1 + k * a_dim1]; + d22 = a[k - 1 + (k - 1) * a_dim1] / d12; + d11 = a[k + k * a_dim1] / d12; + t = 1. / (d11 * d22 - 1.); + + for (j = k - 2; j >= 1; --j) { + + wkm1 = t * (d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]); + wk = t * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]); + + for (i__ = j; i__ >= 1; --i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] / d12 * wk - a[i__ + (k - 1) + * a_dim1] / d12 * wkm1; +/* L20: */ + } + +/* Store U(k) and U(k-1) in cols k and k-1 for row J */ + + a[j + k * a_dim1] = wk / d12; + a[j + (k - 1) * a_dim1] = wkm1 / d12; + +/* L30: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + + } 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 */ +/* 1 or 2 */ + + k = 1; +L40: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L70; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + +/* Test for interchange */ + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABSAKK.GE.ALPHA*COLMAX */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L42: + +/* Begin pivot search loop body */ + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + } else { + rowmax = 0.; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1] + , &c__1); + dtemp = (d__1 = a[itemp + imax * a_dim1], abs(d__1)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */ + + if (! ((d__1 = a[imax + imax * a_dim1], abs(d__1)) < alpha * + rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + done = TRUE_; + +/* Equivalent to testing for ROWMAX .EQ. COLMAX, */ +/* used to handle NaN and Inf */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot NOT found, set variables and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + } + +/* End pivot search loop body */ + + if (! done) { + goto L42; + } + + } + +/* Swap TWO rows and TWO columns */ + +/* First swap */ + + if (kstep == 2 && p != k) { + +/* Interchange rows and column K and P in the trailing */ +/* submatrix A(k:n,k:n) if we have a 2-by-2 pivot */ + + if (p < *n) { + i__1 = *n - p; + dswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p + * a_dim1], &c__1); + } + if (p > k + 1) { + i__1 = p - k - 1; + dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + + 1) * a_dim1], lda); + } + t = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[p + p * a_dim1]; + a[p + p * a_dim1] = t; + } + +/* Second swap */ + + kk = k + kstep - 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; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (kk < *n && kp > kk + 1) { + i__1 = kp - kk - 1; + dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + ( + kk + 1) * a_dim1], lda); + } + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k + 1 + k * a_dim1]; + a[k + 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + } + +/* 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) and */ +/* store L(k) in column k */ + + if ((d__1 = a[k + k * a_dim1], abs(d__1)) >= sfmin) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - L(k)*D(k)*L(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ + + d11 = 1. / a[k + k * a_dim1]; + i__1 = *n - k; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], & + c__1, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Store L(k) in column k */ + + i__1 = *n - k; + dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1); + } else { + +/* Store L(k) in column k */ + + d11 = a[k + k * a_dim1]; + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= d11; +/* L46: */ + } + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - L(k)*D(k)*L(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ +/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */ + + i__1 = *n - k; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], & + c__1, &a[k + 1 + (k + 1) * a_dim1], lda); + } + } + + } 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 */ + + +/* 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) )**T */ +/* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T */ + +/* and store L(k) and L(k+1) in columns k and k+1 */ + + if (k < *n - 1) { + + d21 = a[k + 1 + k * a_dim1]; + d11 = a[k + 1 + (k + 1) * a_dim1] / d21; + d22 = a[k + k * a_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + +/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ + + wk = t * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]); + wkp1 = t * (d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]); + +/* Perform a rank-2 update of A(k+2:n,k+2:n) */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] / d21 * wk - a[i__ + (k + 1) + * a_dim1] / d21 * wkp1; +/* L50: */ + } + +/* Store L(k) and L(k+1) in cols k and k+1 for row J */ + + a[j + k * a_dim1] = wk / d21; + a[j + (k + 1) * a_dim1] = wkp1 / d21; + +/* L60: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L40; + + } + +L70: + + return 0; + +/* End of DSYTF2_ROOK */ + +} /* dsytf2_rook__ */ + diff --git a/lapack-netlib/SRC/dsytrd.c b/lapack-netlib/SRC/dsytrd.c new file mode 100644 index 000000000..60fde69a8 --- /dev/null +++ b/lapack-netlib/SRC/dsytrd.c @@ -0,0 +1,804 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRD reduces a real symmetric matrix A to real symmetric */ +/* > tridiagonal form T by an orthogonal similarity transformation: */ +/* > Q**T * 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, 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 orthogonal */ +/* > 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 orthogonal matrix Q as a product */ +/* > of elementary reflectors. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \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 DOUBLE PRECISION array, dimension (N-1) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= 1. */ +/* > For optimum performance LWORK >= N*NB, where NB is the */ +/* > optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \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**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ +/* > A(1:i-1,i+1), and tau 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**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ +/* > and tau in TAU(i). */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples */ +/* > with n = 5: */ +/* > */ +/* > if UPLO = 'U': if UPLO = 'L': */ +/* > */ +/* > ( d e v2 v3 v4 ) ( d ) */ +/* > ( d e v3 v4 ) ( e d ) */ +/* > ( d e v4 ) ( v1 e d ) */ +/* > ( d e ) ( v1 v2 e d ) */ +/* > ( d ) ( v1 v2 v3 e d ) */ +/* > */ +/* > where d and e denote diagonal and off-diagonal elements of T, and vi */ +/* > denotes an element of the vector defining H(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsytrd_(char *uplo, integer *n, doublereal *a, integer * + lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal * + work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + logical upper; + extern /* Subroutine */ int dsytd2_(char *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, integer *), dsyr2k_(char *, char *, integer *, integer *, doublereal + *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + integer nb, kk, nx; + extern /* Subroutine */ int dlatrd_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + 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; + --d__; + --e; + --tau; + --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 = -9; + } + + if (*info == 0) { + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *n * nb; + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + work[1] = 1.; + return 0; + } + + nx = *n; + iws = 1; + if (nb > 1 && nb < *n) { + +/* Determine when to cross over from blocked to unblocked code */ +/* (last block is always handled by unblocked code). */ + +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__3, "DSYTRD", uplo, n, &c_n1, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *n) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: determine the */ +/* minimum value of NB, and reduce NB or force use of */ +/* unblocked code by setting NX = N. */ + +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = f2cmax(i__1,1); + nbmin = ilaenv_(&c__2, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + if (nb < nbmin) { + nx = *n; + } + } + } else { + nx = *n; + } + } else { + nb = 1; + } + + if (upper) { + +/* Reduce the upper triangle of A. */ +/* Columns 1:kk are handled by the unblocked method. */ + + kk = *n - (*n - nx + nb - 1) / nb * nb; + i__1 = kk + 1; + i__2 = -nb; + for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { + +/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ +/* matrix W which is needed to update the unreduced part of */ +/* the matrix */ + + i__3 = i__ + nb - 1; + dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & + work[1], &ldwork); + +/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ +/* update of the form: A := A - V*W**T - W*V**T */ + + i__3 = i__ - 1; + dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 + + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda); + +/* Copy superdiagonal elements back into A, and diagonal */ +/* elements into D */ + + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j - 1 + j * a_dim1] = e[j - 1]; + d__[j] = a[j + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + +/* Use unblocked code to reduce the last or only block */ + + dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo); + } else { + +/* Reduce the lower triangle of A */ + + i__2 = *n - nx; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + +/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ +/* matrix W which is needed to update the unreduced part of */ +/* the matrix */ + + i__3 = *n - i__ + 1; + dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & + tau[i__], &work[1], &ldwork); + +/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */ +/* an update of the form: A := A - V*W**T - W*V**T */ + + i__3 = *n - i__ - nb + 1; + dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ + i__ + nb + (i__ + nb) * a_dim1], lda); + +/* Copy subdiagonal elements back into A, and diagonal */ +/* elements into D */ + + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + 1 + j * a_dim1] = e[j]; + d__[j] = a[j + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + +/* Use unblocked code to reduce the last or only block */ + + i__1 = *n - i__ + 1; + dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], + &tau[i__], &iinfo); + } + + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DSYTRD */ + +} /* dsytrd_ */ + diff --git a/lapack-netlib/SRC/dsytrd_2stage.c b/lapack-netlib/SRC/dsytrd_2stage.c new file mode 100644 index 000000000..aecd7d885 --- /dev/null +++ b/lapack-netlib/SRC/dsytrd_2stage.c @@ -0,0 +1,747 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRD_2STAGE */ + +/* @generated from zhetrd_2stage.f, fortran z -> d, Sun Nov 6 19:34:06 2016 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRD_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, */ +/* HOUS2, LHOUS2, WORK, LWORK, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER VECT, UPLO */ +/* INTEGER N, LDA, LWORK, LHOUS2, INFO */ +/* DOUBLE PRECISION D( * ), E( * ) */ +/* DOUBLE PRECISION A( LDA, * ), TAU( * ), */ +/* HOUS2( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRD_2STAGE reduces a real symmetric matrix A to real symmetric */ +/* > tridiagonal form T by a orthogonal similarity transformation: */ +/* > Q1**T Q2**T* A * Q2 * Q1 = T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > = 'N': No need for the Housholder representation, */ +/* > in particular for the second stage (Band to */ +/* > tridiagonal) and thus LHOUS2 is of size f2cmax(1, 4*N); */ +/* > = 'V': the Householder representation is needed to */ +/* > either generate Q1 Q2 or to apply Q1 Q2, */ +/* > then LHOUS2 is to be queried and computed. */ +/* > (NOT AVAILABLE IN THIS RELEASE). */ +/* > \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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, if UPLO = 'U', the band superdiagonal */ +/* > of A are overwritten by the corresponding elements of the */ +/* > internal band-diagonal matrix AB, and the elements above */ +/* > the KD superdiagonal, with the array TAU, represent the orthogonal */ +/* > matrix Q1 as a product of elementary reflectors; if UPLO */ +/* > = 'L', the diagonal and band subdiagonal of A are over- */ +/* > written by the corresponding elements of the internal band-diagonal */ +/* > matrix AB, and the elements below the KD subdiagonal, with */ +/* > the array TAU, represent the orthogonal matrix Q1 as a product */ +/* > of elementary reflectors. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The off-diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (N-KD) */ +/* > The scalar factors of the elementary reflectors of */ +/* > the first stage (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] HOUS2 */ +/* > \verbatim */ +/* > HOUS2 is DOUBLE PRECISION array, dimension (LHOUS2) */ +/* > Stores the Householder representation of the stage2 */ +/* > band to tridiagonal. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LHOUS2 */ +/* > \verbatim */ +/* > LHOUS2 is INTEGER */ +/* > The dimension of the array HOUS2. */ +/* > If LWORK = -1, or LHOUS2 = -1, */ +/* > then a query is assumed; the routine */ +/* > only calculates the optimal size of the HOUS2 array, returns */ +/* > this value as the first entry of the HOUS2 array, and no error */ +/* > message related to LHOUS2 is issued by XERBLA. */ +/* > If VECT='N', LHOUS2 = f2cmax(1, 4*n); */ +/* > if VECT='V', option not yet available. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK = MAX(1, dimension) */ +/* > If LWORK = -1, or LHOUS2=-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. */ +/* > LWORK = MAX(1, dimension) where */ +/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N */ +/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ +/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ +/* > + (KD+1)*N */ +/* > where KD is the blocking size of the reduction, */ +/* > FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Implemented by Azzam Haidar. */ +/* > */ +/* > All details are available on technical report, SC11, SC13 papers. */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsytrd_2stage_(char *vect, char *uplo, integer *n, + doublereal *a, integer *lda, doublereal *d__, doublereal *e, + doublereal *tau, doublereal *hous2, integer *lhous2, doublereal *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer ldab; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + integer lwrk; + extern /* Subroutine */ int dsytrd_sb2st_(char *, char *, char *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *); + integer wpos; + extern /* Subroutine */ int dsytrd_sy2sb_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *); + extern logical lsame_(char *, char *); + integer abpos, lhmin, lwmin; + logical wantq, upper; + integer ib, kd; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical lquery; + + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + --e; + --tau; + --hous2; + --work; + + /* Function Body */ + *info = 0; + wantq = lsame_(vect, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *lhous2 == -1; + +/* Determine the block size, the workspace size and the hous size. */ + + kd = ilaenv2stage_(&c__1, "DSYTRD_2STAGE", vect, n, &c_n1, &c_n1, &c_n1); + ib = ilaenv2stage_(&c__2, "DSYTRD_2STAGE", vect, n, &kd, &c_n1, &c_n1); + lhmin = ilaenv2stage_(&c__3, "DSYTRD_2STAGE", vect, n, &kd, &ib, &c_n1); + lwmin = ilaenv2stage_(&c__4, "DSYTRD_2STAGE", vect, n, &kd, &ib, &c_n1); +/* WRITE(*,*),'DSYTRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO, */ +/* $ LHMIN, LWMIN */ + + if (! lsame_(vect, "N")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*lhous2 < lhmin && ! lquery) { + *info = -10; + } else if (*lwork < lwmin && ! lquery) { + *info = -12; + } + + if (*info == 0) { + hous2[1] = (doublereal) lhmin; + work[1] = (doublereal) lwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRD_2STAGE", &i__1, (ftnlen)13); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + work[1] = 1.; + return 0; + } + +/* Determine pointer position */ + + ldab = kd + 1; + lwrk = *lwork - ldab * *n; + abpos = 1; + wpos = abpos + ldab * *n; + dsytrd_sy2sb_(uplo, n, &kd, &a[a_offset], lda, &work[abpos], &ldab, &tau[ + 1], &work[wpos], &lwrk, info); + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRD_SY2SB", &i__1, (ftnlen)12); + return 0; + } + dsytrd_sb2st_("Y", vect, uplo, n, &kd, &work[abpos], &ldab, &d__[1], &e[ + 1], &hous2[1], lhous2, &work[wpos], &lwrk, info); + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRD_SB2ST", &i__1, (ftnlen)12); + return 0; + } + + + hous2[1] = (doublereal) lhmin; + work[1] = (doublereal) lwmin; + return 0; + +/* End of DSYTRD_2STAGE */ + +} /* dsytrd_2stage__ */ + diff --git a/lapack-netlib/SRC/dsytrd_sb2st.c b/lapack-netlib/SRC/dsytrd_sb2st.c new file mode 100644 index 000000000..4724629a5 --- /dev/null +++ b/lapack-netlib/SRC/dsytrd_sb2st.c @@ -0,0 +1,945 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRD_SB2ST + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, */ +/* D, E, HOUS, LHOUS, WORK, LWORK, INFO ) */ + +/* #if defined(_OPENMP) */ +/* use omp_lib */ +/* #endif */ + +/* IMPLICIT NONE */ + +/* CHARACTER STAGE1, UPLO, VECT */ +/* INTEGER N, KD, IB, LDAB, LHOUS, LWORK, INFO */ +/* DOUBLE PRECISION D( * ), E( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), HOUS( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric */ +/* > tridiagonal form T by a orthogonal similarity transformation: */ +/* > Q**T * A * Q = T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] STAGE1 */ +/* > \verbatim */ +/* > STAGE1 is CHARACTER*1 */ +/* > = 'N': "No": to mention that the stage 1 of the reduction */ +/* > from dense to band using the dsytrd_sy2sb routine */ +/* > was not called before this routine to reproduce AB. */ +/* > In other term this routine is called as standalone. */ +/* > = 'Y': "Yes": to mention that the stage 1 of the */ +/* > reduction from dense to band using the dsytrd_sy2sb */ +/* > routine has been called to produce AB (e.g., AB is */ +/* > the output of dsytrd_sy2sb. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > = 'N': No need for the Housholder representation, */ +/* > and thus LHOUS is of size f2cmax(1, 4*N); */ +/* > = 'V': the Householder representation is needed to */ +/* > either generate or to apply Q later on, */ +/* > then LHOUS is to be queried and computed. */ +/* > (NOT AVAILABLE IN THIS RELEASE). */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > On exit, the diagonal elements of AB are overwritten by the */ +/* > diagonal elements of the tridiagonal matrix T; if KD > 0, the */ +/* > elements on the first superdiagonal (if UPLO = 'U') or the */ +/* > first subdiagonal (if UPLO = 'L') are overwritten by the */ +/* > off-diagonal elements of T; the rest of AB is overwritten by */ +/* > values generated during the reduction. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The off-diagonal elements of the tridiagonal matrix T: */ +/* > E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] HOUS */ +/* > \verbatim */ +/* > HOUS is DOUBLE PRECISION array, dimension LHOUS, that */ +/* > store the Householder representation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LHOUS */ +/* > \verbatim */ +/* > LHOUS is INTEGER */ +/* > The dimension of the array HOUS. LHOUS = MAX(1, dimension) */ +/* > If LWORK = -1, or LHOUS=-1, */ +/* > then a query is assumed; the routine */ +/* > only calculates the optimal size of the HOUS array, returns */ +/* > this value as the first entry of the HOUS array, and no error */ +/* > message related to LHOUS is issued by XERBLA. */ +/* > LHOUS = MAX(1, dimension) where */ +/* > dimension = 4*N if VECT='N' */ +/* > not available now if VECT='H' */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK = MAX(1, dimension) */ +/* > If LWORK = -1, or LHOUS=-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. */ +/* > LWORK = MAX(1, dimension) where */ +/* > dimension = (2KD+1)*N + KD*NTHREADS */ +/* > where KD is the blocking size of the reduction, */ +/* > FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice */ +/* > NTHREADS is the number of threads used when */ +/* > openMP compilation is enabled, otherwise =1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup real16OTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Implemented by Azzam Haidar. */ +/* > */ +/* > All details are available on technical report, SC11, SC13 papers. */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsytrd_sb2st_(char *stage1, char *vect, char *uplo, + integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal * + d__, doublereal *e, doublereal *hous, integer *lhous, doublereal * + work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; + real r__1; + + /* Local variables */ + integer inda; + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + integer thed, indv, myid, indw, apos, dpos, abofdpos, nthreads, i__, k, m, + edind, debug; + extern logical lsame_(char *, char *); + integer lhmin, sidev, sizea, shift, stind, colpt, lwmin, awpos; + logical wantq, upper; + integer grsiz, ttype, stepercol, ed, ib, st, abdpos; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + integer thgrid; + extern /* Subroutine */ int dsb2st_kernels_(char *, logical *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *); + integer thgrnb, indtau, ofdpos, blklastind; + extern /* Subroutine */ int mecago_(); + logical lquery, afters1; + integer lda, tid, ldv, stt, sweepid, nbtiles, sizetau, thgrsiz; + + + + +/* -- 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 minimal workspace size required. */ +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --d__; + --e; + --hous; + --work; + + /* Function Body */ + debug = 0; + *info = 0; + afters1 = lsame_(stage1, "Y"); + wantq = lsame_(vect, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *lhous == -1; + +/* Determine the block size, the workspace size and the hous size. */ + + ib = ilaenv2stage_(&c__2, "DSYTRD_SB2ST", vect, n, kd, &c_n1, &c_n1); + lhmin = ilaenv2stage_(&c__3, "DSYTRD_SB2ST", vect, n, kd, &ib, &c_n1); + lwmin = ilaenv2stage_(&c__4, "DSYTRD_SB2ST", vect, n, kd, &ib, &c_n1); + + if (! afters1 && ! lsame_(stage1, "N")) { + *info = -1; + } else if (! lsame_(vect, "N")) { + *info = -2; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } else if (*lhous < lhmin && ! lquery) { + *info = -11; + } else if (*lwork < lwmin && ! lquery) { + *info = -13; + } + + if (*info == 0) { + hous[1] = (doublereal) lhmin; + work[1] = (doublereal) lwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRD_SB2ST", &i__1, (ftnlen)12); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + hous[1] = 1.; + work[1] = 1.; + return 0; + } + +/* Determine pointer position */ + + ldv = *kd + ib; + sizetau = *n << 1; + sidev = *n << 1; + indtau = 1; + indv = indtau + sizetau; + lda = (*kd << 1) + 1; + sizea = lda * *n; + inda = 1; + indw = inda + sizea; + nthreads = 1; + tid = 0; + + if (upper) { + apos = inda + *kd; + awpos = inda; + dpos = apos + *kd; + ofdpos = dpos - 1; + abdpos = *kd + 1; + abofdpos = *kd; + } else { + apos = inda; + awpos = inda + *kd + 1; + dpos = apos; + ofdpos = dpos + 1; + abdpos = 1; + abofdpos = 2; + } + +/* Case KD=0: */ +/* The matrix is diagonal. We just copy it (convert to "real" for */ +/* real because D is double and the imaginary part should be 0) */ +/* and store it in D. A sequential code here is better or */ +/* in a parallel environment it might need two cores for D and E */ + + if (*kd == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[abdpos + i__ * ab_dim1]; +/* L30: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = 0.; +/* L40: */ + } + + hous[1] = 1.; + work[1] = 1.; + return 0; + } + +/* Case KD=1: */ +/* The matrix is already Tridiagonal. We have to make diagonal */ +/* and offdiagonal elements real, and store them in D and E. */ +/* For that, for real precision just copy the diag and offdiag */ +/* to D and E while for the COMPLEX case the bulge chasing is */ +/* performed to convert the hermetian tridiagonal to symmetric */ +/* tridiagonal. A simpler coversion formula might be used, but then */ +/* updating the Q matrix will be required and based if Q is generated */ +/* or not this might complicate the story. */ + + if (*kd == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[abdpos + i__ * ab_dim1]; +/* L50: */ + } + + if (upper) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[abofdpos + (i__ + 1) * ab_dim1]; +/* L60: */ + } + } else { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[abofdpos + i__ * ab_dim1]; +/* L70: */ + } + } + + hous[1] = 1.; + work[1] = 1.; + return 0; + } + +/* Main code start here. */ +/* Reduce the symmetric band of A to a tridiagonal matrix. */ + + thgrsiz = *n; + grsiz = 1; + shift = 3; + r__1 = (real) (*n) / (real) (*kd) + .5f; + nbtiles = r_int(&r__1); + r__1 = (real) shift / (real) grsiz + .5f; + stepercol = r_int(&r__1); + r__1 = (real) (*n - 1) / (real) thgrsiz + .5f; + thgrnb = r_int(&r__1); + + i__1 = *kd + 1; + dlacpy_("A", &i__1, n, &ab[ab_offset], ldab, &work[apos], &lda) + ; + dlaset_("A", kd, n, &c_b26, &c_b26, &work[awpos], &lda); + + +/* openMP parallelisation start here */ + + +/* main bulge chasing loop */ + + i__1 = thgrnb; + for (thgrid = 1; thgrid <= i__1; ++thgrid) { + stt = (thgrid - 1) * thgrsiz + 1; +/* Computing MIN */ + i__2 = stt + thgrsiz - 1, i__3 = *n - 1; + thed = f2cmin(i__2,i__3); + i__2 = *n - 1; + for (i__ = stt; i__ <= i__2; ++i__) { + ed = f2cmin(i__,thed); + if (stt > ed) { + myexit_(); + } + i__3 = stepercol; + for (m = 1; m <= i__3; ++m) { + st = stt; + i__4 = ed; + for (sweepid = st; sweepid <= i__4; ++sweepid) { + i__5 = grsiz; + for (k = 1; k <= i__5; ++k) { + myid = (i__ - sweepid) * (stepercol * grsiz) + (m - 1) + * grsiz + k; + if (myid == 1) { + ttype = 1; + } else { + ttype = myid % 2 + 2; + } + if (ttype == 2) { + colpt = myid / 2 * *kd + sweepid; + stind = colpt - *kd + 1; + edind = f2cmin(colpt,*n); + blklastind = colpt; + } else { + colpt = (myid + 1) / 2 * *kd + sweepid; + stind = colpt - *kd + 1; + edind = f2cmin(colpt,*n); + if (stind >= edind - 1 && edind == *n) { + blklastind = *n; + } else { + blklastind = 0; + } + } + +/* Call the kernel */ + + dsb2st_kernels_(uplo, &wantq, &ttype, &stind, &edind, + &sweepid, n, kd, &ib, &work[inda], &lda, & + hous[indv], &hous[indtau], &ldv, &work[indw + + tid * *kd]); + if (blklastind >= *n - 1) { + ++stt; + myexit_(); + } +/* L140: */ + } +/* L130: */ + } +/* L120: */ + } +/* L110: */ + } +/* L100: */ + } + + +/* Copy the diagonal from A to D. Note that D is REAL thus only */ +/* the Real part is needed, the imaginary part should be zero. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = work[dpos + (i__ - 1) * lda]; +/* L150: */ + } + +/* Copy the off diagonal from A to E. Note that E is REAL thus only */ +/* the Real part is needed, the imaginary part should be zero. */ + + if (upper) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = work[ofdpos + i__ * lda]; +/* L160: */ + } + } else { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = work[ofdpos + (i__ - 1) * lda]; +/* L170: */ + } + } + + hous[1] = (doublereal) lhmin; + work[1] = (doublereal) lwmin; + return 0; + +/* End of DSYTRD_SB2ST */ + +} /* dsytrd_sb2st__ */ + diff --git a/lapack-netlib/SRC/dsytrd_sy2sb.c b/lapack-netlib/SRC/dsytrd_sy2sb.c new file mode 100644 index 000000000..e261d6a69 --- /dev/null +++ b/lapack-netlib/SRC/dsytrd_sy2sb.c @@ -0,0 +1,960 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRD_SY2SB */ + +/* @generated from zhetrd_he2hb.f, fortran z -> d, Wed Dec 7 08:22:39 2016 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRD_SY2SB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, */ +/* WORK, LWORK, INFO ) */ + +/* IMPLICIT NONE */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDAB, LWORK, N, KD */ +/* DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), */ +/* TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric */ +/* > band-diagonal form AB by a orthogonal similarity transformation: */ +/* > Q**T * A * Q = AB. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the reduced matrix if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > The reduced matrix is stored in the array AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, 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 orthogonal */ +/* > 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 orthogonal matrix Q as a product */ +/* > of elementary reflectors. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > On exit, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (N-KD) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > On exit, if INFO = 0, or if LWORK=-1, */ +/* > WORK(1) returns the size of LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK which should be calculated */ +/* > by a workspace query. LWORK = MAX(1, LWORK_QUERY) */ +/* > 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. */ +/* > LWORK_QUERY = N*KD + N*f2cmax(KD,FACTOPTNB) + 2*KD*KD */ +/* > where FACTOPTNB is the blocking used by the QR or LQ */ +/* > algorithm, usually FACTOPTNB=128 is a good choice otherwise */ +/* > putting LWORK=-1 will provide the size of WORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Implemented by Azzam Haidar. */ +/* > */ +/* > All details are available on technical report, SC11, SC13 papers. */ +/* > */ +/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ +/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ +/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ +/* > of 2011 International Conference for High Performance Computing, */ +/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ +/* > Article 8 , 11 pages. */ +/* > http://doi.acm.org/10.1145/2063384.2063394 */ +/* > */ +/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ +/* > An improved parallel singular value algorithm and its implementation */ +/* > for multicore hardware, In Proceedings of 2013 International Conference */ +/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ +/* > Denver, Colorado, USA, 2013. */ +/* > Article 90, 12 pages. */ +/* > http://doi.acm.org/10.1145/2503210.2503292 */ +/* > */ +/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ +/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ +/* > calculations based on fine-grained memory aware tasks. */ +/* > International Journal of High Performance Computing Applications. */ +/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ +/* > http://hpc.sagepub.com/content/28/2/196 */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(k)**T . . . H(2)**T H(1)**T, where k = n-kd. */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in */ +/* > A(i,i+kd+1:n), and tau in TAU(i). */ +/* > */ +/* > If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = n-kd. */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in */ +/* > A(i+kd+2:n,i), and tau in TAU(i). */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples */ +/* > with n = 5: */ +/* > */ +/* > if UPLO = 'U': if UPLO = 'L': */ +/* > */ +/* > ( ab ab/v1 v1 v1 v1 ) ( ab ) */ +/* > ( ab ab/v2 v2 v2 ) ( ab/v1 ab ) */ +/* > ( ab ab/v3 v3 ) ( v1 ab/v2 ab ) */ +/* > ( ab ab/v4 ) ( v1 v2 ab/v3 ab ) */ +/* > ( ab ) ( v1 v2 v3 ab/v4 ab ) */ +/* > */ +/* > where d and e denote diagonal and off-diagonal elements of T, and vi */ +/* > denotes an element of the vector defining H(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsytrd_sy2sb_(char *uplo, integer *n, integer *kd, + doublereal *a, integer *lda, doublereal *ab, integer *ldab, + doublereal *tau, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4, + i__5; + + /* Local variables */ + extern integer ilaenv2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + integer tpos, wpos, s1pos, s2pos, i__, j; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer lwmin; + extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dsyr2k_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer lk, pk, pn, lt; + extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *); + integer lw; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlarft_(char *, char *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), dlaset_(char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *); + integer ls1; + logical lquery; + integer ls2, ldt, ldw, lds1, lds2; + + + +/* -- 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 minimal workspace size required */ +/* and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + lwmin = ilaenv2stage_(&c__4, "DSYTRD_SY2SB", "", n, kd, &c_n1, &c_n1); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *kd + 1; + if (*ldab < f2cmax(i__1,i__2)) { + *info = -7; + } else if (*lwork < lwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRD_SY2SB", &i__1, (ftnlen)12); + return 0; + } else if (lquery) { + work[1] = (doublereal) lwmin; + return 0; + } + +/* Quick return if possible */ +/* Copy the upper/lower portion of A into AB */ + + if (*n <= *kd + 1) { + if (upper) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ + i__2 = *kd + 1; + lk = f2cmin(i__2,i__); + dcopy_(&lk, &a[i__ - lk + 1 + i__ * a_dim1], &c__1, &ab[*kd + + 1 - lk + 1 + i__ * ab_dim1], &c__1); +/* L100: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ + i__2 = *kd + 1, i__3 = *n - i__ + 1; + lk = f2cmin(i__2,i__3); + dcopy_(&lk, &a[i__ + i__ * a_dim1], &c__1, &ab[i__ * ab_dim1 + + 1], &c__1); +/* L110: */ + } + } + work[1] = 1.; + return 0; + } + +/* Determine the pointer position for the workspace */ + + ldt = *kd; + lds1 = *kd; + lt = ldt * *kd; + lw = *n * *kd; + ls1 = lds1 * *kd; + ls2 = lwmin - lt - lw - ls1; +/* LS2 = N*MAX(KD,FACTOPTNB) */ + tpos = 1; + wpos = tpos + lt; + s1pos = wpos + lw; + s2pos = s1pos + ls1; + if (upper) { + ldw = *kd; + lds2 = *kd; + } else { + ldw = *n; + lds2 = *n; + } + + +/* Set the workspace of the triangular matrix T to zero once such a */ +/* way every time T is generated the upper/lower portion will be always zero */ + + dlaset_("A", &ldt, kd, &c_b17, &c_b17, &work[tpos], &ldt); + + if (upper) { + i__1 = *n - *kd; + i__2 = *kd; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + pn = *n - i__ - *kd + 1; +/* Computing MIN */ + i__3 = *n - i__ - *kd + 1; + pk = f2cmin(i__3,*kd); + +/* Compute the LQ factorization of the current block */ + + dgelqf_(kd, &pn, &a[i__ + (i__ + *kd) * a_dim1], lda, &tau[i__], & + work[s2pos], &ls2, &iinfo); + +/* Copy the upper portion of A into AB */ + + i__3 = i__ + pk - 1; + for (j = i__; j <= i__3; ++j) { +/* Computing MIN */ + i__4 = *kd, i__5 = *n - j; + lk = f2cmin(i__4,i__5) + 1; + i__4 = *ldab - 1; + dcopy_(&lk, &a[j + j * a_dim1], lda, &ab[*kd + 1 + j * + ab_dim1], &i__4); +/* L20: */ + } + + dlaset_("Lower", &pk, &pk, &c_b17, &c_b23, &a[i__ + (i__ + *kd) * + a_dim1], lda); + +/* Form the matrix T */ + + dlarft_("Forward", "Rowwise", &pn, &pk, &a[i__ + (i__ + *kd) * + a_dim1], lda, &tau[i__], &work[tpos], &ldt); + +/* Compute W: */ + + dgemm_("Conjugate", "No transpose", &pk, &pn, &pk, &c_b23, &work[ + tpos], &ldt, &a[i__ + (i__ + *kd) * a_dim1], lda, &c_b17, + &work[s2pos], &lds2); + + dsymm_("Right", uplo, &pk, &pn, &c_b23, &a[i__ + *kd + (i__ + *kd) + * a_dim1], lda, &work[s2pos], &lds2, &c_b17, &work[wpos], + &ldw); + + dgemm_("No transpose", "Conjugate", &pk, &pk, &pn, &c_b23, &work[ + wpos], &ldw, &work[s2pos], &lds2, &c_b17, &work[s1pos], & + lds1); + + dgemm_("No transpose", "No transpose", &pk, &pn, &pk, &c_b39, & + work[s1pos], &lds1, &a[i__ + (i__ + *kd) * a_dim1], lda, & + c_b23, &work[wpos], &ldw); + + +/* Update the unreduced submatrix A(i+kd:n,i+kd:n), using */ +/* an update of the form: A := A - V'*W - W'*V */ + + dsyr2k_(uplo, "Conjugate", &pn, &pk, &c_b42, &a[i__ + (i__ + *kd) + * a_dim1], lda, &work[wpos], &ldw, &c_b23, &a[i__ + *kd + + (i__ + *kd) * a_dim1], lda); +/* L10: */ + } + +/* Copy the upper band to AB which is the band storage matrix */ + + i__2 = *n; + for (j = *n - *kd + 1; j <= i__2; ++j) { +/* Computing MIN */ + i__1 = *kd, i__3 = *n - j; + lk = f2cmin(i__1,i__3) + 1; + i__1 = *ldab - 1; + dcopy_(&lk, &a[j + j * a_dim1], lda, &ab[*kd + 1 + j * ab_dim1], & + i__1); +/* L30: */ + } + + } else { + +/* Reduce the lower triangle of A to lower band matrix */ + + i__2 = *n - *kd; + i__1 = *kd; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + pn = *n - i__ - *kd + 1; +/* Computing MIN */ + i__3 = *n - i__ - *kd + 1; + pk = f2cmin(i__3,*kd); + +/* Compute the QR factorization of the current block */ + + dgeqrf_(&pn, kd, &a[i__ + *kd + i__ * a_dim1], lda, &tau[i__], & + work[s2pos], &ls2, &iinfo); + +/* Copy the upper portion of A into AB */ + + i__3 = i__ + pk - 1; + for (j = i__; j <= i__3; ++j) { +/* Computing MIN */ + i__4 = *kd, i__5 = *n - j; + lk = f2cmin(i__4,i__5) + 1; + dcopy_(&lk, &a[j + j * a_dim1], &c__1, &ab[j * ab_dim1 + 1], & + c__1); +/* L50: */ + } + + dlaset_("Upper", &pk, &pk, &c_b17, &c_b23, &a[i__ + *kd + i__ * + a_dim1], lda); + +/* Form the matrix T */ + + dlarft_("Forward", "Columnwise", &pn, &pk, &a[i__ + *kd + i__ * + a_dim1], lda, &tau[i__], &work[tpos], &ldt); + +/* Compute W: */ + + dgemm_("No transpose", "No transpose", &pn, &pk, &pk, &c_b23, &a[ + i__ + *kd + i__ * a_dim1], lda, &work[tpos], &ldt, &c_b17, + &work[s2pos], &lds2); + + dsymm_("Left", uplo, &pn, &pk, &c_b23, &a[i__ + *kd + (i__ + *kd) + * a_dim1], lda, &work[s2pos], &lds2, &c_b17, &work[wpos], + &ldw); + + dgemm_("Conjugate", "No transpose", &pk, &pk, &pn, &c_b23, &work[ + s2pos], &lds2, &work[wpos], &ldw, &c_b17, &work[s1pos], & + lds1); + + dgemm_("No transpose", "No transpose", &pn, &pk, &pk, &c_b39, &a[ + i__ + *kd + i__ * a_dim1], lda, &work[s1pos], &lds1, & + c_b23, &work[wpos], &ldw); + + +/* Update the unreduced submatrix A(i+kd:n,i+kd:n), using */ +/* an update of the form: A := A - V*W' - W*V' */ + + dsyr2k_(uplo, "No transpose", &pn, &pk, &c_b42, &a[i__ + *kd + + i__ * a_dim1], lda, &work[wpos], &ldw, &c_b23, &a[i__ + * + kd + (i__ + *kd) * a_dim1], lda); +/* ================================================================== */ +/* RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED */ +/* DO 45 J = I, I+PK-1 */ +/* LK = MIN( KD, N-J ) + 1 */ +/* CALL DCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 ) */ +/* 45 CONTINUE */ +/* ================================================================== */ +/* L40: */ + } + +/* Copy the lower band to AB which is the band storage matrix */ + + i__1 = *n; + for (j = *n - *kd + 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + lk = f2cmin(i__2,i__3) + 1; + dcopy_(&lk, &a[j + j * a_dim1], &c__1, &ab[j * ab_dim1 + 1], & + c__1); +/* L60: */ + } + } + + work[1] = (doublereal) lwmin; + return 0; + +/* End of DSYTRD_SY2SB */ + +} /* dsytrd_sy2sb__ */ + diff --git a/lapack-netlib/SRC/dsytrf_aa_2stage.c b/lapack-netlib/SRC/dsytrf_aa_2stage.c new file mode 100644 index 000000000..4a0f7fc8e --- /dev/null +++ b/lapack-netlib/SRC/dsytrf_aa_2stage.c @@ -0,0 +1,1116 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRF_AA_2STAGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRF_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRF_AA_2STAGE( UPLO, N, A, LDA, TB, LTB, IPIV, */ +/* IPIV2, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LTB, LWORK, INFO */ +/* INTEGER IPIV( * ), IPIV2( * ) */ +/* DOUBLE PRECISION A( LDA, * ), TB( * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRF_AA_2STAGE computes the factorization of a real symmetric matrix A */ +/* > using the Aasen's algorithm. The form of the factorization is */ +/* > */ +/* > A = U**T*T*U or A = L*T*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is a symmetric 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 DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, 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 DOUBLE PRECISION 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 IPIV2(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION 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 doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrf_aa_2stage_(char *uplo, integer *n, doublereal *a, + integer *lda, doublereal *tb, integer *ltb, integer *ipiv, integer * + ipiv2, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer ldtb, i__, j, k; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *), dtrsm_(char *, char *, char *, char * + , integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer i1; + logical upper; + integer i2, jb, kb, nb, td, nt; + extern /* Subroutine */ int dgbtrf_(integer *, integer *, integer *, + integer *, doublereal *, integer *, integer *, integer *), + dgetrf_(integer *, integer *, doublereal *, integer *, integer *, + integer *), dlacpy_(char *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dsygst_(integer *, char *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *); + logical tquery, wquery; + doublereal 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_("DSYTRF_AA_2STAGE", &i__1, (ftnlen)16); + return 0; + } + +/* Answer the query */ + + nb = ilaenv_(&c__1, "DSYTRF_AA_2STAGE", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)16, (ftnlen)1); + if (*info == 0) { + if (tquery) { + tb[1] = (doublereal) ((nb * 3 + 1) * *n); + } + if (wquery) { + work[1] = (doublereal) (*n * nb); + } + } + 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] = (doublereal) nb; + + if (upper) { + +/* ..................................................... */ +/* Factorize A as U**T*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,I+1)*U(I+1,J) */ + if (i__ == j - 1) { + jb = nb + kb; + } else { + jb = nb << 1; + } + i__3 = ldtb - 1; + dgemm_("NoTranspose", "NoTranspose", &nb, &kb, &jb, & + c_b12, &tb[td + 1 + i__ * nb * ldtb], &i__3, &a[( + i__ - 1) * nb + 1 + (j * nb + 1) * a_dim1], lda, & + c_b13, &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; + dgemm_("NoTranspose", "NoTranspose", &nb, &kb, &jb, & + c_b12, &tb[td + nb + 1 + (i__ - 1) * nb * ldtb], & + i__3, &a[(i__ - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b13, &work[i__ * nb + 1], n); + } + } + +/* Compute T(J,J) */ + + i__2 = ldtb - 1; + dlacpy_("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; + dgemm_("Transpose", "NoTranspose", &kb, &kb, &i__2, &c_b21, & + a[(j * nb + 1) * a_dim1 + 1], lda, &work[nb + 1], n, & + c_b12, &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; + dgemm_("Transpose", "NoTranspose", &kb, &nb, &kb, &c_b12, &a[( + j - 1) * nb + 1 + (j * nb + 1) * a_dim1], lda, &tb[td + + nb + 1 + (j - 1) * nb * ldtb], &i__2, &c_b13, &work[ + 1], n); + i__2 = ldtb - 1; + dgemm_("NoTranspose", "NoTranspose", &kb, &kb, &nb, &c_b21, & + work[1], n, &a[(j - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b12, &tb[td + 1 + j * nb * ldtb], & + i__2); + } + if (j > 0) { + i__2 = ldtb - 1; + dsygst_(&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 = kb; + for (k = i__ + 1; k <= i__3; ++k) { + tb[td + (k - i__) + 1 + (j * nb + i__ - 1) * ldtb] = tb[ + td - (k - (i__ + 1)) + (j * nb + k - 1) * ldtb]; + } + } + + if (j < nt - 1) { + if (j > 0) { + +/* Compute H(J,J) */ + + if (j == 1) { + i__2 = ldtb - 1; + dgemm_("NoTranspose", "NoTranspose", &kb, &kb, &kb, & + c_b12, &tb[td + 1 + j * nb * ldtb], &i__2, &a[ + (j - 1) * nb + 1 + (j * nb + 1) * a_dim1], + lda, &c_b13, &work[j * nb + 1], n); + } else { + i__2 = nb + kb; + i__3 = ldtb - 1; + dgemm_("NoTranspose", "NoTranspose", &kb, &kb, &i__2, + &c_b12, &tb[td + nb + 1 + (j - 1) * nb * ldtb] + , &i__3, &a[(j - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b13, &work[j * nb + 1], n); + } + +/* Update with the previous column */ + + i__2 = *n - (j + 1) * nb; + i__3 = j * nb; + dgemm_("Transpose", "NoTranspose", &nb, &i__2, &i__3, & + c_b21, &work[nb + 1], n, &a[((j + 1) * nb + 1) * + a_dim1 + 1], lda, &c_b12, &a[j * nb + 1 + ((j + 1) + * nb + 1) * a_dim1], lda); + } + +/* Copy panel to workspace to call DGETRF */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = *n - (j + 1) * nb; + dcopy_(&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; + dgetrf_(&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) { + i__3 = *n - (j + 1) * nb; + dcopy_(&i__3, &work[(k - 1) * *n + 1], &c__1, &a[j * nb + + k + ((j + 1) * nb + 1) * a_dim1], lda); + } + +/* 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; + dlaset_("Full", &kb, &nb, &c_b13, &c_b13, &tb[td + nb + 1 + j + * nb * ldtb], &i__2); + i__2 = ldtb - 1; + dlacpy_("Upper", &kb, &nb, &work[1], n, &tb[td + nb + 1 + j * + nb * ldtb], &i__2); + if (j > 0) { + i__2 = ldtb - 1; + dtrsm_("R", "U", "N", "U", &kb, &nb, &c_b12, &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__) { + tb[td - nb + k - i__ + 1 + (j * nb + nb + i__ - 1) * + ldtb] = tb[td + nb + i__ - k + 1 + (j * nb + + k - 1) * ldtb]; + } + } + dlaset_("Lower", &kb, &nb, &c_b13, &c_b12, &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; + dswap_(&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; + dswap_(&i__3, &a[i1 + (i1 + 1) * a_dim1], lda, &a[ + i1 + 1 + i2 * a_dim1], &c__1); + } +/* > Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + if (i2 < *n) { + i__3 = *n - i2; + dswap_(&i__3, &a[i1 + (i2 + 1) * a_dim1], lda, &a[ + i2 + (i2 + 1) * a_dim1], lda); + } +/* > Swap A(I1, I1) with A(I2, I2) */ + piv = a[i1 + i1 * a_dim1]; + a[i1 + i1 * a_dim1] = a[i2 + i2 * a_dim1]; + a[i2 + i2 * a_dim1] = piv; +/* > Apply pivots to previous columns of L */ + if (j > 0) { + i__3 = j * nb; + dswap_(&i__3, &a[i1 * a_dim1 + 1], &c__1, &a[i2 * + a_dim1 + 1], &c__1); + } + } + } + } + } + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T 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; + dgemm_("NoTranspose", "Transpose", &nb, &kb, &jb, &c_b12, + &tb[td + 1 + i__ * nb * ldtb], &i__3, &a[j * nb + + 1 + ((i__ - 1) * nb + 1) * a_dim1], lda, &c_b13, & + 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; + dgemm_("NoTranspose", "Transpose", &nb, &kb, &jb, &c_b12, + &tb[td + nb + 1 + (i__ - 1) * nb * ldtb], &i__3, & + a[j * nb + 1 + ((i__ - 2) * nb + 1) * a_dim1], + lda, &c_b13, &work[i__ * nb + 1], n); + } + } + +/* Compute T(J,J) */ + + i__2 = ldtb - 1; + dlacpy_("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; + dgemm_("NoTranspose", "NoTranspose", &kb, &kb, &i__2, &c_b21, + &a[j * nb + 1 + a_dim1], lda, &work[nb + 1], n, & + c_b12, &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; + dgemm_("NoTranspose", "NoTranspose", &kb, &nb, &kb, &c_b12, & + a[j * nb + 1 + ((j - 1) * nb + 1) * a_dim1], lda, &tb[ + td + nb + 1 + (j - 1) * nb * ldtb], &i__2, &c_b13, & + work[1], n); + i__2 = ldtb - 1; + dgemm_("NoTranspose", "Transpose", &kb, &kb, &nb, &c_b21, & + work[1], n, &a[j * nb + 1 + ((j - 2) * nb + 1) * + a_dim1], lda, &c_b12, &tb[td + 1 + j * nb * ldtb], & + i__2); + } + if (j > 0) { + i__2 = ldtb - 1; + dsygst_(&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 = kb; + for (k = i__ + 1; k <= i__3; ++k) { + tb[td - (k - (i__ + 1)) + (j * nb + k - 1) * ldtb] = tb[ + td + (k - i__) + 1 + (j * nb + i__ - 1) * ldtb]; + } + } + + if (j < nt - 1) { + if (j > 0) { + +/* Compute H(J,J) */ + + if (j == 1) { + i__2 = ldtb - 1; + dgemm_("NoTranspose", "Transpose", &kb, &kb, &kb, & + c_b12, &tb[td + 1 + j * nb * ldtb], &i__2, &a[ + j * nb + 1 + ((j - 1) * nb + 1) * a_dim1], + lda, &c_b13, &work[j * nb + 1], n); + } else { + i__2 = nb + kb; + i__3 = ldtb - 1; + dgemm_("NoTranspose", "Transpose", &kb, &kb, &i__2, & + c_b12, &tb[td + nb + 1 + (j - 1) * nb * ldtb], + &i__3, &a[j * nb + 1 + ((j - 2) * nb + 1) * + a_dim1], lda, &c_b13, &work[j * nb + 1], n); + } + +/* Update with the previous column */ + + i__2 = *n - (j + 1) * nb; + i__3 = j * nb; + dgemm_("NoTranspose", "NoTranspose", &i__2, &nb, &i__3, & + c_b21, &a[(j + 1) * nb + 1 + a_dim1], lda, &work[ + nb + 1], n, &c_b12, &a[(j + 1) * nb + 1 + (j * nb + + 1) * a_dim1], lda); + } + +/* Factorize panel */ + + i__2 = *n - (j + 1) * nb; + dgetrf_(&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; + dlaset_("Full", &kb, &nb, &c_b13, &c_b13, &tb[td + nb + 1 + j + * nb * ldtb], &i__2); + i__2 = ldtb - 1; + dlacpy_("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; + dtrsm_("R", "L", "T", "U", &kb, &nb, &c_b12, &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__) { + tb[td - nb + k - i__ + 1 + (j * nb + nb + i__ - 1) * + ldtb] = tb[td + nb + i__ - k + 1 + (j * nb + + k - 1) * ldtb]; + } + } + dlaset_("Upper", &kb, &nb, &c_b13, &c_b12, &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; + dswap_(&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; + dswap_(&i__3, &a[i1 + 1 + i1 * a_dim1], &c__1, &a[ + i2 + (i1 + 1) * a_dim1], lda); + } +/* > Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + if (i2 < *n) { + i__3 = *n - i2; + dswap_(&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) */ + piv = a[i1 + i1 * a_dim1]; + a[i1 + i1 * a_dim1] = a[i2 + i2 * a_dim1]; + a[i2 + i2 * a_dim1] = piv; +/* > Apply pivots to previous columns of L */ + if (j > 0) { + i__3 = j * nb; + dswap_(&i__3, &a[i1 + a_dim1], lda, &a[i2 + + a_dim1], lda); + } + } + } + +/* Apply pivots to previous columns of L */ + +/* CALL DLASWP( J*NB, A( 1, 1 ), LDA, */ +/* $ (J+1)*NB+1, (J+1)*NB+KB, IPIV, 1 ) */ + } + } + } + +/* Factor the band matrix */ + dgbtrf_(n, n, &nb, &nb, &tb[1], &ldtb, &ipiv2[1], info); + + return 0; + +/* End of DSYTRF_AA_2STAGE */ + +} /* dsytrf_aa_2stage__ */ +