From 08fba4906d4d67b4aa9c4633a9ff1678daf9ed9b Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 22 Feb 2022 23:34:04 +0100 Subject: [PATCH] Add C versions as fallback --- lapack-netlib/SRC/sla_lin_berr.c | 548 +++++++++ lapack-netlib/SRC/sla_porcond.c | 745 ++++++++++++ lapack-netlib/SRC/sla_porfsx_extended.c | 1095 +++++++++++++++++ lapack-netlib/SRC/sla_porpvgrw.c | 625 ++++++++++ lapack-netlib/SRC/sla_syamv.c | 802 ++++++++++++ lapack-netlib/SRC/sla_syrcond.c | 762 ++++++++++++ lapack-netlib/SRC/sla_syrfsx_extended.c | 1126 +++++++++++++++++ lapack-netlib/SRC/sla_syrpvgrw.c | 763 ++++++++++++ lapack-netlib/SRC/sla_wwaddw.c | 504 ++++++++ lapack-netlib/SRC/slabad.c | 489 ++++++++ lapack-netlib/SRC/slabrd.c | 883 ++++++++++++++ lapack-netlib/SRC/slacn2.c | 700 +++++++++++ lapack-netlib/SRC/slacon.c | 679 +++++++++++ lapack-netlib/SRC/slacpy.c | 556 +++++++++ lapack-netlib/SRC/sladiv.c | 621 ++++++++++ lapack-netlib/SRC/slae2.c | 566 +++++++++ lapack-netlib/SRC/slaebz.c | 1099 +++++++++++++++++ lapack-netlib/SRC/slaed0.c | 876 ++++++++++++++ lapack-netlib/SRC/slaed1.c | 690 +++++++++++ lapack-netlib/SRC/slaed2.c | 994 +++++++++++++++ lapack-netlib/SRC/slaed3.c | 785 ++++++++++++ lapack-netlib/SRC/slaed4.c | 1378 +++++++++++++++++++++ lapack-netlib/SRC/slaed5.c | 573 +++++++++ lapack-netlib/SRC/slaed6.c | 810 +++++++++++++ lapack-netlib/SRC/slaed7.c | 830 +++++++++++++ lapack-netlib/SRC/slaed8.c | 961 +++++++++++++++ lapack-netlib/SRC/slaed9.c | 719 +++++++++++ lapack-netlib/SRC/slaeda.c | 732 +++++++++++ lapack-netlib/SRC/slaein.c | 1134 +++++++++++++++++ lapack-netlib/SRC/slaev2.c | 619 ++++++++++ lapack-netlib/SRC/slaexc.c | 896 ++++++++++++++ lapack-netlib/SRC/slag2.c | 795 ++++++++++++ lapack-netlib/SRC/slag2d.c | 535 ++++++++ lapack-netlib/SRC/slags2.c | 748 ++++++++++++ lapack-netlib/SRC/slagtf.c | 660 ++++++++++ lapack-netlib/SRC/slagtm.c | 704 +++++++++++ lapack-netlib/SRC/slagts.c | 786 ++++++++++++ lapack-netlib/SRC/slagv2.c | 793 ++++++++++++ lapack-netlib/SRC/slahqr.c | 1089 +++++++++++++++++ lapack-netlib/SRC/slahr2.c | 761 ++++++++++++ lapack-netlib/SRC/slaic1.c | 756 ++++++++++++ lapack-netlib/SRC/slaisnan.c | 481 ++++++++ lapack-netlib/SRC/slaln2.c | 1032 ++++++++++++++++ lapack-netlib/SRC/slals0.c | 952 +++++++++++++++ lapack-netlib/SRC/slalsa.c | 946 +++++++++++++++ lapack-netlib/SRC/slalsd.c | 969 +++++++++++++++ lapack-netlib/SRC/slamrg.c | 566 +++++++++ lapack-netlib/SRC/slamswlq.c | 845 +++++++++++++ lapack-netlib/SRC/slamtsqr.c | 843 +++++++++++++ lapack-netlib/SRC/slaneg.c | 641 ++++++++++ lapack-netlib/SRC/slangb.c | 663 ++++++++++ lapack-netlib/SRC/slange.c | 634 ++++++++++ lapack-netlib/SRC/slangt.c | 624 ++++++++++ lapack-netlib/SRC/slanhs.c | 635 ++++++++++ lapack-netlib/SRC/slansb.c | 714 +++++++++++ lapack-netlib/SRC/slansf.c | 1479 +++++++++++++++++++++++ lapack-netlib/SRC/slansp.c | 707 +++++++++++ lapack-netlib/SRC/slanst.c | 587 +++++++++ lapack-netlib/SRC/slansy.c | 686 +++++++++++ lapack-netlib/SRC/slantb.c | 886 ++++++++++++++ lapack-netlib/SRC/slantp.c | 839 +++++++++++++ lapack-netlib/SRC/slantr.c | 852 +++++++++++++ lapack-netlib/SRC/slanv2.c | 707 +++++++++++ lapack-netlib/SRC/slaorhr_col_getrfnp.c | 653 ++++++++++ 64 files changed, 50128 insertions(+) create mode 100644 lapack-netlib/SRC/sla_lin_berr.c create mode 100644 lapack-netlib/SRC/sla_porcond.c create mode 100644 lapack-netlib/SRC/sla_porfsx_extended.c create mode 100644 lapack-netlib/SRC/sla_porpvgrw.c create mode 100644 lapack-netlib/SRC/sla_syamv.c create mode 100644 lapack-netlib/SRC/sla_syrcond.c create mode 100644 lapack-netlib/SRC/sla_syrfsx_extended.c create mode 100644 lapack-netlib/SRC/sla_syrpvgrw.c create mode 100644 lapack-netlib/SRC/sla_wwaddw.c create mode 100644 lapack-netlib/SRC/slabad.c create mode 100644 lapack-netlib/SRC/slabrd.c create mode 100644 lapack-netlib/SRC/slacn2.c create mode 100644 lapack-netlib/SRC/slacon.c create mode 100644 lapack-netlib/SRC/slacpy.c create mode 100644 lapack-netlib/SRC/sladiv.c create mode 100644 lapack-netlib/SRC/slae2.c create mode 100644 lapack-netlib/SRC/slaebz.c create mode 100644 lapack-netlib/SRC/slaed0.c create mode 100644 lapack-netlib/SRC/slaed1.c create mode 100644 lapack-netlib/SRC/slaed2.c create mode 100644 lapack-netlib/SRC/slaed3.c create mode 100644 lapack-netlib/SRC/slaed4.c create mode 100644 lapack-netlib/SRC/slaed5.c create mode 100644 lapack-netlib/SRC/slaed6.c create mode 100644 lapack-netlib/SRC/slaed7.c create mode 100644 lapack-netlib/SRC/slaed8.c create mode 100644 lapack-netlib/SRC/slaed9.c create mode 100644 lapack-netlib/SRC/slaeda.c create mode 100644 lapack-netlib/SRC/slaein.c create mode 100644 lapack-netlib/SRC/slaev2.c create mode 100644 lapack-netlib/SRC/slaexc.c create mode 100644 lapack-netlib/SRC/slag2.c create mode 100644 lapack-netlib/SRC/slag2d.c create mode 100644 lapack-netlib/SRC/slags2.c create mode 100644 lapack-netlib/SRC/slagtf.c create mode 100644 lapack-netlib/SRC/slagtm.c create mode 100644 lapack-netlib/SRC/slagts.c create mode 100644 lapack-netlib/SRC/slagv2.c create mode 100644 lapack-netlib/SRC/slahqr.c create mode 100644 lapack-netlib/SRC/slahr2.c create mode 100644 lapack-netlib/SRC/slaic1.c create mode 100644 lapack-netlib/SRC/slaisnan.c create mode 100644 lapack-netlib/SRC/slaln2.c create mode 100644 lapack-netlib/SRC/slals0.c create mode 100644 lapack-netlib/SRC/slalsa.c create mode 100644 lapack-netlib/SRC/slalsd.c create mode 100644 lapack-netlib/SRC/slamrg.c create mode 100644 lapack-netlib/SRC/slamswlq.c create mode 100644 lapack-netlib/SRC/slamtsqr.c create mode 100644 lapack-netlib/SRC/slaneg.c create mode 100644 lapack-netlib/SRC/slangb.c create mode 100644 lapack-netlib/SRC/slange.c create mode 100644 lapack-netlib/SRC/slangt.c create mode 100644 lapack-netlib/SRC/slanhs.c create mode 100644 lapack-netlib/SRC/slansb.c create mode 100644 lapack-netlib/SRC/slansf.c create mode 100644 lapack-netlib/SRC/slansp.c create mode 100644 lapack-netlib/SRC/slanst.c create mode 100644 lapack-netlib/SRC/slansy.c create mode 100644 lapack-netlib/SRC/slantb.c create mode 100644 lapack-netlib/SRC/slantp.c create mode 100644 lapack-netlib/SRC/slantr.c create mode 100644 lapack-netlib/SRC/slanv2.c create mode 100644 lapack-netlib/SRC/slaorhr_col_getrfnp.c diff --git a/lapack-netlib/SRC/sla_lin_berr.c b/lapack-netlib/SRC/sla_lin_berr.c new file mode 100644 index 000000000..160da7375 --- /dev/null +++ b/lapack-netlib/SRC/sla_lin_berr.c @@ -0,0 +1,548 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_LIN_BERR computes a component-wise relative backward error. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_LIN_BERR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) */ + +/* INTEGER N, NZ, NRHS */ +/* REAL AYB( N, NRHS ), BERR( NRHS ) */ +/* REAL RES( N, NRHS ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLA_LIN_BERR computes componentwise relative backward error from */ +/* > the formula */ +/* > f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NZ */ +/* > \verbatim */ +/* > NZ is INTEGER */ +/* > We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */ +/* > guard against spuriously zero residuals. Default value is N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices AYB, RES, and BERR. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is REAL array, dimension (N,NRHS) */ +/* > The residual matrix, i.e., the matrix R in the relative backward */ +/* > error formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is REAL array, dimension (N, NRHS) */ +/* > The denominator in the relative backward error formula above, i.e., */ +/* > the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */ +/* > are from iterative refinement (see sla_gerfsx_extended.f). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error from the formula above. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sla_lin_berr_(integer *n, integer *nz, integer *nrhs, + real *res, real *ayb, real *berr) +{ + /* System generated locals */ + integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2; + real r__1; + + /* Local variables */ + real safe1; + integer i__, j; + extern real slamch_(char *); + real tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Adding SAFE1 to the numerator guards against spuriously zero */ +/* residuals. A similar safeguard is in the SLA_yyAMV routine used */ +/* to compute AYB. */ + + /* Parameter adjustments */ + --berr; + ayb_dim1 = *n; + ayb_offset = 1 + ayb_dim1 * 1; + ayb -= ayb_offset; + res_dim1 = *n; + res_offset = 1 + res_dim1 * 1; + res -= res_offset; + + /* Function Body */ + safe1 = slamch_("Safe minimum"); + safe1 = (*nz + 1) * safe1; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (ayb[i__ + j * ayb_dim1] != 0.f) { + tmp = (safe1 + (r__1 = res[i__ + j * res_dim1], abs(r__1))) / + ayb[i__ + j * ayb_dim1]; +/* Computing MAX */ + r__1 = berr[j]; + berr[j] = f2cmax(r__1,tmp); + } + +/* If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know */ +/* the true residual also must be exactly 0.0. */ + + } + } + return 0; +} /* sla_lin_berr__ */ + diff --git a/lapack-netlib/SRC/sla_porcond.c b/lapack-netlib/SRC/sla_porcond.c new file mode 100644 index 000000000..e5e4b8f99 --- /dev/null +++ b/lapack-netlib/SRC/sla_porcond.c @@ -0,0 +1,745 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_PORCOND estimates the Skeel condition number for a symmetric positive-definite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_PORCOND + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, */ +/* INFO, WORK, IWORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LDAF, INFO, CMODE */ +/* REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), */ +/* $ C( * ) */ +/* INTEGER IWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) */ +/* > where op2 is determined by CMODE as follows */ +/* > CMODE = 1 op2(C) = C */ +/* > CMODE = 0 op2(C) = I */ +/* > CMODE = -1 op2(C) = inv(C) */ +/* > The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */ +/* > is computed by computing scaling factors R such that */ +/* > diag(R)*A*op2(C) is row equilibrated and computing the standard */ +/* > infinity-norm condition number. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is REAL array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**T*U or A = L*L**T, as computed by SPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CMODE */ +/* > \verbatim */ +/* > CMODE is INTEGER */ +/* > Determines op2(C) in the formula op(A) * op2(C) as follows: */ +/* > CMODE = 1 op2(C) = C */ +/* > CMODE = 0 op2(C) = I */ +/* > CMODE = -1 op2(C) = inv(C) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The vector C in the formula op(A) * op2(C). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realPOcomputational */ + +/* ===================================================================== */ +real sla_porcond_(char *uplo, integer *n, real *a, integer *lda, real *af, + integer *ldaf, integer *cmode, real *c__, integer *info, real *work, + integer *iwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + real ret_val, r__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, + real *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real ainvnm; + extern /* Subroutine */ int spotrs_(char *, integer *, integer *, real *, + integer *, real *, integer *, integer *); + real tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.f; + + *info = 0; + if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLA_PORCOND", &i__1, (ftnlen)11); + return ret_val; + } + if (*n == 0) { + ret_val = 1.f; + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute the equilibration matrix R such that */ +/* inv(R)*A*C has unit 1-norm. */ + + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.f; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], abs(r__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1], abs(r__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], abs(r__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.f; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], abs(r__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1], abs(r__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], abs(r__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.f; + kase = 0; +L10: + slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + if (up) { + spotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + spotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by inv(C). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + } else { + +/* Multiply by inv(C**T). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + if (up) { + spotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + spotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + ret_val = 1.f / ainvnm; + } + + return ret_val; + +} /* sla_porcond__ */ + diff --git a/lapack-netlib/SRC/sla_porfsx_extended.c b/lapack-netlib/SRC/sla_porfsx_extended.c new file mode 100644 index 000000000..45741e957 --- /dev/null +++ b/lapack-netlib/SRC/sla_porfsx_extended.c @@ -0,0 +1,1095 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_PORFSX_EXTENDED improves the computed solution to a system of linear equations for symmetri +c or Hermitian positive-definite matrices by performing extra-precise iterative refinement and provide +s error bounds and backward error estimates fo */ +/* r the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_PORFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, */ +/* AF, LDAF, COLEQU, C, B, LDB, Y, */ +/* LDY, BERR_OUT, N_NORMS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, */ +/* AYB, DY, Y_TAIL, RCOND, ITHRESH, */ +/* RTHRESH, DZ_UB, IGNORE_CWISE, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ N_NORMS, ITHRESH */ +/* CHARACTER UPLO */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* REAL RTHRESH, DZ_UB */ +/* REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* REAL C( * ), AYB(*), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLA_PORFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by SPORFSX to perform iterative refinement. */ +/* > In addition to normwise error bound, the code provides maximum */ +/* > componentwise error bound if possible. See comments for ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP for details of the error bounds. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is REAL array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**T*U or A = L*L**T, as computed by SPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. If C is input, each element of C should be a power */ +/* > of the radix to ensure a reliable solution and error estimates. */ +/* > Scaling by powers of the radix does not cause rounding errors unless */ +/* > the result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by SPOTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is REAL array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by SLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is REAL array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is REAL array, dimension (N) */ +/* > Workspace. This can be the same workspace passed for Y_TAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is REAL array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is REAL array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For 'aggressive' set to 100 to */ +/* > permit convergence using approximate factorizations or */ +/* > factorizations other than LU. If the factorization uses a */ +/* > technique other than Gaussian elimination, the guarantees in */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is REAL */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is REAL */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to SPOTRS 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 realPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sla_porfsx_extended_(integer *prec_type__, char *uplo, + integer *n, integer *nrhs, real *a, integer *lda, real *af, integer * + ldaf, logical *colequ, real *c__, real *b, integer *ldb, real *y, + integer *ldy, real *berr_out__, integer *n_norms__, real * + err_bnds_norm__, real *err_bnds_comp__, real *res, real *ayb, real * + dy, real *y_tail__, real *rcond, integer *ithresh, real *rthresh, + real *dz_ub__, logical *ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + real dx_x__, dz_z__, ymin; + extern /* Subroutine */ int sla_lin_berr_(integer *, integer *, integer * + , real *, real *, real *); + real dxratmax, dzratmax; + integer y_prec_state__, uplo2; + extern /* Subroutine */ int blas_ssymv_x_(integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *, + integer *); + integer i__, j; + extern logical lsame_(char *, char *); + real dxrat; + logical incr_prec__; + real dzrat; + extern /* Subroutine */ int blas_ssymv2_x_(integer *, integer *, real *, + real *, integer *, real *, real *, integer *, real *, real *, + integer *, integer *), scopy_(integer *, real *, integer *, real * + , integer *); + real normx, normy; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *), sla_syamv_(integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real myhugeval, prev_dz_z__; + extern /* Subroutine */ int ssymv_(char *, integer *, real *, real *, + integer *, real *, integer *, real *, real *, integer *); + real yk; + extern real slamch_(char *); + real final_dx_x__, final_dz_z__, normdx; + extern /* Subroutine */ int sla_wwaddw_(integer *, real *, real *, real * + ), spotrs_(char *, integer *, integer *, real *, integer *, real * + , integer *, integer *); + real prevnormdx; + integer cnt; + real dyk, eps; + extern integer ilauplo_(char *); + integer x_state__, z_state__; + real incr_thresh__; + + +/* -- 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 */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + eps = slamch_("Epsilon"); + myhugeval = slamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (real) (*n) * eps; + if (lsame_(uplo, "L")) { + uplo2 = ilauplo_("L"); + } else { + uplo2 = ilauplo_("U"); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + y_tail__[i__] = 0.f; + } + } + dxrat = 0.f; + dxratmax = 0.f; + dzrat = 0.f; + dzratmax = 0.f; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + ssymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b11, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_ssymv_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j * + y_dim1 + 1], &c__1, &c_b11, &res[1], &c__1, + prec_type__); + } else { + blas_ssymv2_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j * + y_dim1 + 1], &y_tail__[1], &c__1, &c_b11, &res[1], & + c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + scopy_(n, &res[1], &c__1, &dy[1], &c__1); + spotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &dy[1], n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.f; + normy = 0.f; + normdx = 0.f; + dz_z__ = 0.f; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + yk = (r__1 = y[i__ + j * y_dim1], abs(r__1)); + dyk = (r__1 = dy[i__], abs(r__1)); + if (yk != 0.f) { +/* Computing MAX */ + r__1 = dz_z__, r__2 = dyk / yk; + dz_z__ = f2cmax(r__1,r__2); + } else if (dyk != 0.f) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + r__1 = normx, r__2 = yk * c__[i__]; + normx = f2cmax(r__1,r__2); +/* Computing MAX */ + r__1 = normdx, r__2 = dyk * c__[i__]; + normdx = f2cmax(r__1,r__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.f) { + dx_x__ = normdx / normx; + } else if (normdx == 0.f) { + dx_x__ = 0.f; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.f; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { + goto L666; + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + y_tail__[i__] = 0.f; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + saxpy_(n, &c_b11, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + sla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds. */ + + if (*n_norms__ >= 1) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( + 1 - dxratmax); + } + if (*n_norms__ >= 2) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( + 1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + ssymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, & + c_b11, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + ayb[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + sla_syamv_(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b11, &ayb[1], &c__1); + sla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* sla_porfsx_extended__ */ + diff --git a/lapack-netlib/SRC/sla_porpvgrw.c b/lapack-netlib/SRC/sla_porpvgrw.c new file mode 100644 index 000000000..313074dd5 --- /dev/null +++ b/lapack-netlib/SRC/sla_porpvgrw.c @@ -0,0 +1,625 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_PORPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric or Her +mitian positive-definite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_PORPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) */ + +/* CHARACTER*1 UPLO */ +/* INTEGER NCOLS, LDA, LDAF */ +/* REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > SLA_PORPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, the stability of the LU factorization of the */ +/* > (equilibrated) matrix A could be poor. This also means that the */ +/* > solution X, estimated condition numbers, and error bounds could be */ +/* > unreliable. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCOLS */ +/* > \verbatim */ +/* > NCOLS is INTEGER */ +/* > The number of columns of the matrix A. NCOLS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is REAL array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**T*U or A = L*L**T, as computed by SPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realPOcomputational */ + +/* ===================================================================== */ +real sla_porpvgrw_(char *uplo, integer *ncols, real *a, integer *lda, real * + af, integer *ldaf, real *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + real ret_val, r__1, r__2, r__3; + + /* Local variables */ + real amax, umax; + integer i__, j; + extern logical lsame_(char *, char *); + logical upper; + real rpvgrw; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --work; + + /* Function Body */ + upper = lsame_("Upper", uplo); + +/* SPOTRF will have factored only the NCOLSxNCOLS leading minor, so */ +/* we restrict the growth search to that minor and use only the first */ +/* 2*NCOLS workspace entries. */ + + rpvgrw = 1.f; + i__1 = *ncols << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + +/* Find the f2cmax magnitude entry of each column. */ + + if (upper) { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)), r__3 = work[* + ncols + j]; + work[*ncols + j] = f2cmax(r__2,r__3); + } + } + } else { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = *ncols; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)), r__3 = work[* + ncols + j]; + work[*ncols + j] = f2cmax(r__2,r__3); + } + } + } + +/* Now find the f2cmax magnitude entry of each column of the factor in */ +/* AF. No pivoting, so no permutations. */ + + if (lsame_("Upper", uplo)) { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = af[i__ + j * af_dim1], abs(r__1)), r__3 = work[ + j]; + work[j] = f2cmax(r__2,r__3); + } + } + } else { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = *ncols; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = af[i__ + j * af_dim1], abs(r__1)), r__3 = work[ + j]; + work[j] = f2cmax(r__2,r__3); + } + } + } + +/* Compute the *inverse* of the f2cmax element growth factor. Dividing */ +/* by zero would imply the largest entry of the factor's column is */ +/* zero. Than can happen when either the column of A is zero or */ +/* massive pivots made the factor underflow to zero. Neither counts */ +/* as growth in itself, so simply ignore terms with zero */ +/* denominators. */ + + if (lsame_("Upper", uplo)) { + i__1 = *ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*ncols + i__]; + if (umax != 0.f) { +/* Computing MIN */ + r__1 = amax / umax; + rpvgrw = f2cmin(r__1,rpvgrw); + } + } + } else { + i__1 = *ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*ncols + i__]; + if (umax != 0.f) { +/* Computing MIN */ + r__1 = amax / umax; + rpvgrw = f2cmin(r__1,rpvgrw); + } + } + } + ret_val = rpvgrw; + return ret_val; +} /* sla_porpvgrw__ */ + diff --git a/lapack-netlib/SRC/sla_syamv.c b/lapack-netlib/SRC/sla_syamv.c new file mode 100644 index 000000000..c99ec8ffb --- /dev/null +++ b/lapack-netlib/SRC/sla_syamv.c @@ -0,0 +1,802 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate err +or bounds. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_SYAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, */ +/* INCY ) */ + +/* REAL ALPHA, BETA */ +/* INTEGER INCX, INCY, LDA, N, UPLO */ +/* REAL A( LDA, * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLA_SYAMV performs the matrix-vector operation */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > n by n symmetric matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is INTEGER */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the array A is to be referenced as */ +/* > follows: */ +/* > */ +/* > UPLO = BLAS_UPPER Only the upper triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > UPLO = BLAS_LOWER Only the lower triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL . */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension ( LDA, n ). */ +/* > Before entry, the leading m by n part of the array A must */ +/* > contain the matrix of coefficients. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > On entry, LDA specifies the first dimension of A as declared */ +/* > in the calling (sub) program. LDA must be at least */ +/* > f2cmax( 1, n ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCX ) ) */ +/* > Before entry, the incremented array X must contain the */ +/* > vector x. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > On entry, INCX specifies the increment for the elements of */ +/* > X. INCX must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is REAL . */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 2 Blas routine. */ +/* > */ +/* > -- Written on 22-October-1986. */ +/* > Jack Dongarra, Argonne National Lab. */ +/* > Jeremy Du Croz, Nag Central Office. */ +/* > Sven Hammarling, Nag Central Office. */ +/* > Richard Hanson, Sandia National Labs. */ +/* > -- Modified for the absolute-value product, April 2006 */ +/* > Jason Riedy, UC Berkeley */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sla_syamv_(integer *uplo, integer *n, real *alpha, real + *a, integer *lda, real *x, integer *incx, real *beta, real *y, + integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1; + + /* Local variables */ + integer info; + real temp, safe1; + integer i__, j; + logical symb_zero__; + integer iy, jx, kx, ky; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilauplo_(char *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L") + ) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < f2cmax(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("SLA_SYAMV", &info, (ftnlen)9); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f && *beta == 1.f) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = slamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + iy = ky; + if (*incx == 1) { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.f) { + symb_zero__ = TRUE_; + y[iy] = 0.f; + } else if (y[iy] == 0.f) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (r__1 = y[iy], abs(r__1)); + } + if (*alpha != 0.f) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (r__1 = a[j + i__ * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[j], abs(r__1)) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[j], abs(r__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += r_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.f) { + symb_zero__ = TRUE_; + y[iy] = 0.f; + } else if (y[iy] == 0.f) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (r__1 = y[iy], abs(r__1)); + } + if (*alpha != 0.f) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[j], abs(r__1)) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (r__1 = a[j + i__ * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[j], abs(r__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += r_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.f) { + symb_zero__ = TRUE_; + y[iy] = 0.f; + } else if (y[iy] == 0.f) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (r__1 = y[iy], abs(r__1)); + } + jx = kx; + if (*alpha != 0.f) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (r__1 = a[j + i__ * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[jx], abs(r__1)) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[jx], abs(r__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += r_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.f) { + symb_zero__ = TRUE_; + y[iy] = 0.f; + } else if (y[iy] == 0.f) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (r__1 = y[iy], abs(r__1)); + } + jx = kx; + if (*alpha != 0.f) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[jx], abs(r__1)) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (r__1 = a[j + i__ * a_dim1], abs(r__1)); + symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == + 0.f); + y[iy] += *alpha * (r__1 = x[jx], abs(r__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += r_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of SLA_SYAMV */ + +} /* sla_syamv__ */ + diff --git a/lapack-netlib/SRC/sla_syrcond.c b/lapack-netlib/SRC/sla_syrcond.c new file mode 100644 index 000000000..69eecf061 --- /dev/null +++ b/lapack-netlib/SRC/sla_syrcond.c @@ -0,0 +1,762 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_SYRCOND estimates the Skeel condition number for a symmetric indefinite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_SYRCOND + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, */ +/* C, INFO, WORK, IWORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LDAF, INFO, CMODE */ +/* INTEGER IWORK( * ), IPIV( * ) */ +/* REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) */ +/* > where op2 is determined by CMODE as follows */ +/* > CMODE = 1 op2(C) = C */ +/* > CMODE = 0 op2(C) = I */ +/* > CMODE = -1 op2(C) = inv(C) */ +/* > The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */ +/* > is computed by computing scaling factors R such that */ +/* > diag(R)*A*op2(C) is row equilibrated and computing the standard */ +/* > infinity-norm condition number. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is REAL array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by SSYTRF. */ +/* > \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 SSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CMODE */ +/* > \verbatim */ +/* > CMODE is INTEGER */ +/* > Determines op2(C) in the formula op(A) * op2(C) as follows: */ +/* > CMODE = 1 op2(C) = C */ +/* > CMODE = 0 op2(C) = I */ +/* > CMODE = -1 op2(C) = inv(C) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The vector C in the formula op(A) * op2(C). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYcomputational */ + +/* ===================================================================== */ +real sla_syrcond_(char *uplo, integer *n, real *a, integer *lda, real *af, + integer *ldaf, integer *ipiv, integer *cmode, real *c__, integer * + info, real *work, integer *iwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + real ret_val, r__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, + real *, integer *, integer *); + logical up; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real ainvnm; + char normin[1]; + real smlnum; + extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *, + integer *, integer *, real *, integer *, integer *); + real tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.f; + + *info = 0; + if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLA_SYRCOND", &i__1, (ftnlen)11); + return ret_val; + } + if (*n == 0) { + ret_val = 1.f; + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute the equilibration matrix R such that */ +/* inv(R)*A*C has unit 1-norm. */ + + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.f; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], abs(r__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1], abs(r__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], abs(r__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.f; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], abs(r__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1], abs(r__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], abs(r__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], abs(r__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + smlnum = slamch_("Safe minimum"); + ainvnm = 0.f; + *(unsigned char *)normin = 'N'; + kase = 0; +L10: + slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + if (up) { + ssytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + ssytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by inv(C). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + } else { + +/* Multiply by inv(C**T). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + if (up) { + ssytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + ssytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + } + + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + ret_val = 1.f / ainvnm; + } + + return ret_val; + +} /* sla_syrcond__ */ + diff --git a/lapack-netlib/SRC/sla_syrfsx_extended.c b/lapack-netlib/SRC/sla_syrfsx_extended.c new file mode 100644 index 000000000..ccf58e940 --- /dev/null +++ b/lapack-netlib/SRC/sla_syrfsx_extended.c @@ -0,0 +1,1126 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetri +c indefinite matrices by performing extra-precise iterative refinement and provides error bounds and b +ackward error estimates for the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_SYRFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, */ +/* AF, LDAF, IPIV, COLEQU, C, B, LDB, */ +/* Y, LDY, BERR_OUT, N_NORMS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, */ +/* AYB, DY, Y_TAIL, RCOND, ITHRESH, */ +/* RTHRESH, DZ_UB, IGNORE_CWISE, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ N_NORMS, ITHRESH */ +/* CHARACTER UPLO */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* REAL RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > SLA_SYRFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by SSYRFSX to perform iterative refinement. */ +/* > In addition to normwise error bound, the code provides maximum */ +/* > componentwise error bound if possible. See comments for ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP for details of the error bounds. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is REAL array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by SSYTRF. */ +/* > \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 SSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. If C is input, each element of C should be a power */ +/* > of the radix to ensure a reliable solution and error estimates. */ +/* > Scaling by powers of the radix does not cause rounding errors unless */ +/* > the result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by SSYTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is REAL array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by SLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is REAL array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is REAL array, dimension (N) */ +/* > Workspace. This can be the same workspace passed for Y_TAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is REAL array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is REAL array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For 'aggressive' set to 100 to */ +/* > permit convergence using approximate factorizations or */ +/* > factorizations other than LU. If the factorization uses a */ +/* > technique other than Gaussian elimination, the guarantees in */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is REAL */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is REAL */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to SLA_SYRFSX_EXTENDED had an illegal */ +/* > value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sla_syrfsx_extended_(integer *prec_type__, char *uplo, + integer *n, integer *nrhs, real *a, integer *lda, real *af, integer * + ldaf, integer *ipiv, logical *colequ, real *c__, real *b, integer * + ldb, real *y, integer *ldy, real *berr_out__, integer *n_norms__, + real *err_bnds_norm__, real *err_bnds_comp__, real *res, real *ayb, + real *dy, real *y_tail__, real *rcond, integer *ithresh, real * + rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + real dx_x__, dz_z__, ymin; + extern /* Subroutine */ int sla_lin_berr_(integer *, integer *, integer * + , real *, real *, real *); + real dxratmax, dzratmax; + integer y_prec_state__, uplo2; + extern /* Subroutine */ int blas_ssymv_x_(integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *, + integer *); + integer i__, j; + extern logical lsame_(char *, char *); + real dxrat; + logical incr_prec__; + real dzrat; + extern /* Subroutine */ int blas_ssymv2_x_(integer *, integer *, real *, + real *, integer *, real *, real *, integer *, real *, real *, + integer *, integer *); + logical upper; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real normx, normy; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *), sla_syamv_(integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real myhugeval, prev_dz_z__; + extern /* Subroutine */ int ssymv_(char *, integer *, real *, real *, + integer *, real *, integer *, real *, real *, integer *); + real yk; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real final_dx_x__, final_dz_z__, normdx; + extern /* Subroutine */ int sla_wwaddw_(integer *, real *, real *, real * + ), ssytrs_(char *, integer *, integer *, real *, integer *, + integer *, real *, integer *, integer *); + real prevnormdx; + integer cnt; + real dyk, eps; + extern integer ilauplo_(char *); + integer x_state__, z_state__; + real incr_thresh__; + + +/* -- 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 */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldy < f2cmax(1,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLA_SYRFSX_EXTENDED", &i__1, (ftnlen)19); + return 0; + } + eps = slamch_("Epsilon"); + myhugeval = slamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (real) (*n) * eps; + if (lsame_(uplo, "L")) { + uplo2 = ilauplo_("L"); + } else { + uplo2 = ilauplo_("U"); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + y_tail__[i__] = 0.f; + } + } + dxrat = 0.f; + dxratmax = 0.f; + dzrat = 0.f; + dzratmax = 0.f; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + ssymv_(uplo, n, &c_b12, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b14, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_ssymv_x__(&uplo2, n, &c_b12, &a[a_offset], lda, &y[j * + y_dim1 + 1], &c__1, &c_b14, &res[1], &c__1, + prec_type__); + } else { + blas_ssymv2_x__(&uplo2, n, &c_b12, &a[a_offset], lda, &y[j * + y_dim1 + 1], &y_tail__[1], &c__1, &c_b14, &res[1], & + c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + scopy_(n, &res[1], &c__1, &dy[1], &c__1); + ssytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], n, + info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.f; + normy = 0.f; + normdx = 0.f; + dz_z__ = 0.f; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + yk = (r__1 = y[i__ + j * y_dim1], abs(r__1)); + dyk = (r__1 = dy[i__], abs(r__1)); + if (yk != 0.f) { +/* Computing MAX */ + r__1 = dz_z__, r__2 = dyk / yk; + dz_z__ = f2cmax(r__1,r__2); + } else if (dyk != 0.f) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + r__1 = normx, r__2 = yk * c__[i__]; + normx = f2cmax(r__1,r__2); +/* Computing MAX */ + r__1 = normdx, r__2 = dyk * c__[i__]; + normdx = f2cmax(r__1,r__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.f) { + dx_x__ = normdx / normx; + } else if (normdx == 0.f) { + dx_x__ = 0.f; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.f; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { + goto L666; + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + y_tail__[i__] = 0.f; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + saxpy_(n, &c_b14, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + sla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds. */ + + if (*n_norms__ >= 1) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( + 1 - dxratmax); + } + if (*n_norms__ >= 2) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( + 1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + ssymv_(uplo, n, &c_b12, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, + &c_b14, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + ayb[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + sla_syamv_(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b14, &ayb[1], &c__1); + sla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* sla_syrfsx_extended__ */ + diff --git a/lapack-netlib/SRC/sla_syrpvgrw.c b/lapack-netlib/SRC/sla_syrpvgrw.c new file mode 100644 index 000000000..5e2ef7a5e --- /dev/null +++ b/lapack-netlib/SRC/sla_syrpvgrw.c @@ -0,0 +1,763 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefi +nite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_SYRPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, */ +/* WORK ) */ + +/* CHARACTER*1 UPLO */ +/* INTEGER N, INFO, LDA, LDAF */ +/* INTEGER IPIV( * ) */ +/* REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > SLA_SYRPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, the stability of the LU factorization of the */ +/* > (equilibrated) matrix A could be poor. This also means that the */ +/* > solution X, estimated condition numbers, and error bounds could be */ +/* > unreliable. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > The value of INFO returned from SSYTRF, .i.e., the pivot in */ +/* > column INFO is exactly 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is REAL array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by SSYTRF. */ +/* > \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 SSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYcomputational */ + +/* ===================================================================== */ +real sla_syrpvgrw_(char *uplo, integer *n, integer *info, real *a, integer * + lda, real *af, integer *ldaf, integer *ipiv, real *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + real ret_val, r__1, r__2, r__3; + + /* Local variables */ + real amax, umax; + integer i__, j, k; + extern logical lsame_(char *, char *); + integer ncols; + logical upper; + integer kp; + real rpvgrw, tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --work; + + /* Function Body */ + upper = lsame_("Upper", uplo); + if (*info == 0) { + if (upper) { + ncols = 1; + } else { + ncols = *n; + } + } else { + ncols = *info; + } + rpvgrw = 1.f; + i__1 = *n << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + +/* Find the f2cmax magnitude entry of each column of A. Compute the f2cmax */ +/* for all N columns so we can apply the pivot permutation while */ +/* looping below. Assume a full factorization is the common case. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)), r__3 = work[* + n + i__]; + work[*n + i__] = f2cmax(r__2,r__3); +/* Computing MAX */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)), r__3 = work[* + n + j]; + work[*n + j] = f2cmax(r__2,r__3); + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)), r__3 = work[* + n + i__]; + work[*n + i__] = f2cmax(r__2,r__3); +/* Computing MAX */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)), r__3 = work[* + n + j]; + work[*n + j] = f2cmax(r__2,r__3); + } + } + } + +/* Now find the f2cmax magnitude entry of each column of U or L. Also */ +/* permute the magnitudes of A above so they're in the same order as */ +/* the factor. */ + +/* The iteration orders and permutations were copied from ssytrs. */ +/* Calls to SSWAP would be severe overkill. */ + + if (upper) { + k = *n; + while(k < ncols && k > 0) { + if (ipiv[k] > 0) { +/* 1x1 pivot */ + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = af[i__ + k * af_dim1], abs(r__1)), r__3 = + work[k]; + work[k] = f2cmax(r__2,r__3); + } + --k; + } else { +/* 2x2 pivot */ + kp = -ipiv[k]; + tmp = work[*n + k - 1]; + work[*n + k - 1] = work[*n + kp]; + work[*n + kp] = tmp; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = af[i__ + k * af_dim1], abs(r__1)), r__3 = + work[k]; + work[k] = f2cmax(r__2,r__3); +/* Computing MAX */ + r__2 = (r__1 = af[i__ + (k - 1) * af_dim1], abs(r__1)), + r__3 = work[k - 1]; + work[k - 1] = f2cmax(r__2,r__3); + } +/* Computing MAX */ + r__2 = (r__1 = af[k + k * af_dim1], abs(r__1)), r__3 = work[k] + ; + work[k] = f2cmax(r__2,r__3); + k += -2; + } + } + k = ncols; + while(k <= *n) { + if (ipiv[k] > 0) { + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + ++k; + } else { + kp = -ipiv[k]; + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + k += 2; + } + } + } else { + k = 1; + while(k <= ncols) { + if (ipiv[k] > 0) { +/* 1x1 pivot */ + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + i__1 = *n; + for (i__ = k; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = af[i__ + k * af_dim1], abs(r__1)), r__3 = + work[k]; + work[k] = f2cmax(r__2,r__3); + } + ++k; + } else { +/* 2x2 pivot */ + kp = -ipiv[k]; + tmp = work[*n + k + 1]; + work[*n + k + 1] = work[*n + kp]; + work[*n + kp] = tmp; + i__1 = *n; + for (i__ = k + 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = (r__1 = af[i__ + k * af_dim1], abs(r__1)), r__3 = + work[k]; + work[k] = f2cmax(r__2,r__3); +/* Computing MAX */ + r__2 = (r__1 = af[i__ + (k + 1) * af_dim1], abs(r__1)), + r__3 = work[k + 1]; + work[k + 1] = f2cmax(r__2,r__3); + } +/* Computing MAX */ + r__2 = (r__1 = af[k + k * af_dim1], abs(r__1)), r__3 = work[k] + ; + work[k] = f2cmax(r__2,r__3); + k += 2; + } + } + k = ncols; + while(k >= 1) { + if (ipiv[k] > 0) { + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + --k; + } else { + kp = -ipiv[k]; + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + k += -2; + } + } + } + +/* Compute the *inverse* of the f2cmax element growth factor. Dividing */ +/* by zero would imply the largest entry of the factor's column is */ +/* zero. Than can happen when either the column of A is zero or */ +/* massive pivots made the factor underflow to zero. Neither counts */ +/* as growth in itself, so simply ignore terms with zero */ +/* denominators. */ + + if (upper) { + i__1 = *n; + for (i__ = ncols; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*n + i__]; + if (umax != 0.f) { +/* Computing MIN */ + r__1 = amax / umax; + rpvgrw = f2cmin(r__1,rpvgrw); + } + } + } else { + i__1 = ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*n + i__]; + if (umax != 0.f) { +/* Computing MIN */ + r__1 = amax / umax; + rpvgrw = f2cmin(r__1,rpvgrw); + } + } + } + ret_val = rpvgrw; + return ret_val; +} /* sla_syrpvgrw__ */ + diff --git a/lapack-netlib/SRC/sla_wwaddw.c b/lapack-netlib/SRC/sla_wwaddw.c new file mode 100644 index 000000000..db00a3f1c --- /dev/null +++ b/lapack-netlib/SRC/sla_wwaddw.c @@ -0,0 +1,504 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLA_WWADDW adds a vector into a doubled-single vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLA_WWADDW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLA_WWADDW( N, X, Y, W ) */ + +/* INTEGER N */ +/* REAL X( * ), Y( * ), W( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */ +/* > */ +/* > This works for all extant IBM's hex and binary floating point */ +/* > arithmetic, but not for decimal. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of vectors X, Y, and W. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > The first part of the doubled-single accumulation vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension (N) */ +/* > The second part of the doubled-single accumulation vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The vector to be added. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sla_wwaddw_(integer *n, real *x, real *y, real *w) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__; + real s; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --w; + --y; + --x; + + /* Function Body */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s = x[i__] + w[i__]; + s = s + s - s; + y[i__] = x[i__] - s + w[i__] + y[i__]; + x[i__] = s; +/* L10: */ + } + return 0; +} /* sla_wwaddw__ */ + diff --git a/lapack-netlib/SRC/slabad.c b/lapack-netlib/SRC/slabad.c new file mode 100644 index 000000000..2ac99cac8 --- /dev/null +++ b/lapack-netlib/SRC/slabad.c @@ -0,0 +1,489 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLABAD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLABAD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLABAD( SMALL, LARGE ) */ + +/* REAL LARGE, SMALL */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLABAD takes as input the values computed by SLAMCH for underflow and */ +/* > overflow, and returns the square root of each of these values if the */ +/* > log of LARGE is sufficiently large. This subroutine is intended to */ +/* > identify machines with a large exponent range, such as the Crays, and */ +/* > redefine the underflow and overflow limits to be the square roots of */ +/* > the values computed by SLAMCH. This subroutine is needed because */ +/* > SLAMCH does not compensate for poor arithmetic in the upper half of */ +/* > the exponent range, as is found on a Cray. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in,out] SMALL */ +/* > \verbatim */ +/* > SMALL is REAL */ +/* > On entry, the underflow threshold as computed by SLAMCH. */ +/* > On exit, if LOG10(LARGE) is sufficiently large, the square */ +/* > root of SMALL, otherwise unchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] LARGE */ +/* > \verbatim */ +/* > LARGE is REAL */ +/* > On entry, the overflow threshold as computed by SLAMCH. */ +/* > On exit, if LOG10(LARGE) is sufficiently large, the square */ +/* > root of LARGE, otherwise unchanged. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slabad_(real *small, real *large) +{ + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* If it looks like we're on a Cray, take the square root of */ +/* SMALL and LARGE to avoid overflow and underflow problems. */ + + if (r_lg10(large) > 2e3f) { + *small = sqrt(*small); + *large = sqrt(*large); + } + + return 0; + +/* End of SLABAD */ + +} /* slabad_ */ + diff --git a/lapack-netlib/SRC/slabrd.c b/lapack-netlib/SRC/slabrd.c new file mode 100644 index 000000000..6f3b2f06a --- /dev/null +++ b/lapack-netlib/SRC/slabrd.c @@ -0,0 +1,883 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLABRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, */ +/* LDY ) */ + +/* INTEGER LDA, LDX, LDY, M, N, NB */ +/* REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), */ +/* $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLABRD reduces the first NB rows and columns of a real general */ +/* > m by n matrix A to upper or lower bidiagonal form by an orthogonal */ +/* > transformation Q**T * A * P, and returns the matrices X and Y which */ +/* > are needed to apply the transformation to the unreduced part of A. */ +/* > */ +/* > If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */ +/* > bidiagonal form. */ +/* > */ +/* > This is an auxiliary routine called by SGEBRD */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows in the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns in the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of leading rows and columns of A to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the m by n general matrix to be reduced. */ +/* > On exit, the first NB rows and columns of the matrix are */ +/* > overwritten; the rest of the array is unchanged. */ +/* > If m >= n, elements on and below the diagonal in the first NB */ +/* > columns, with the array TAUQ, represent the orthogonal */ +/* > matrix Q as a product of elementary reflectors; and */ +/* > elements above the diagonal in the first NB rows, with the */ +/* > array TAUP, represent the orthogonal matrix P as a product */ +/* > of elementary reflectors. */ +/* > If m < n, elements below the diagonal in the first NB */ +/* > columns, with the array TAUQ, represent the orthogonal */ +/* > matrix Q as a product of elementary reflectors, and */ +/* > elements on and above the diagonal in the first NB rows, */ +/* > with the array TAUP, represent the orthogonal matrix P as */ +/* > a product of elementary reflectors. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (NB) */ +/* > The diagonal elements of the first NB rows and columns of */ +/* > the reduced matrix. D(i) = A(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (NB) */ +/* > The off-diagonal elements of the first NB rows and columns of */ +/* > the reduced matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ */ +/* > \verbatim */ +/* > TAUQ is REAL array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the orthogonal matrix Q. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP */ +/* > \verbatim */ +/* > TAUP is REAL array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the orthogonal matrix P. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NB) */ +/* > The m-by-nb matrix X required to update the unreduced part */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension (LDY,NB) */ +/* > The n-by-nb matrix Y required to update the unreduced part */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrices Q and P are represented as products of elementary */ +/* > reflectors: */ +/* > */ +/* > Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */ +/* > */ +/* > Each H(i) and G(i) has the form: */ +/* > */ +/* > H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T */ +/* > */ +/* > where tauq and taup are real scalars, and v and u are real vectors. */ +/* > */ +/* > If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */ +/* > A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */ +/* > A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */ +/* > A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */ +/* > A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > The elements of the vectors v and u together form the m-by-nb matrix */ +/* > V and the nb-by-n matrix U**T which are needed, with X and Y, to apply */ +/* > the transformation to the unreduced part of the matrix, using a block */ +/* > update of the form: A := A - V*Y**T - X*U**T. */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples */ +/* > with nb = 2: */ +/* > */ +/* > m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ +/* > */ +/* > ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */ +/* > ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */ +/* > ( v1 v2 a a a ) ( v1 1 a a a a ) */ +/* > ( v1 v2 a a a ) ( v1 v2 a a a a ) */ +/* > ( v1 v2 a a a ) ( v1 v2 a a a a ) */ +/* > ( v1 v2 a a a ) */ +/* > */ +/* > where a denotes an element of the original matrix which is unchanged, */ +/* > vi denotes an element of the vector defining H(i), and ui an element */ +/* > of the vector defining G(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slabrd_(integer *m, integer *n, integer *nb, real *a, + integer *lda, real *d__, real *e, real *tauq, real *taup, real *x, + integer *ldx, real *y, integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *), slarfg_( + integer *, real *, real *, integer *, real *); + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + + if (*m >= *n) { + +/* Reduce to upper bidiagonal form */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i:m,i) */ + + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, + &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], & + c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, + &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ * + a_dim1], &c__1); + +/* Generate reflection Q(i) to annihilate A(i+1:m,i) */ + + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[f2cmin(i__3,*m) + i__ * + a_dim1], &c__1, &tauq[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + a[i__ + i__ * a_dim1] = 1.f; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__ + 1; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * + a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, & + y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], + lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ + i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], + ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * + a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, + &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *n - i__; + sscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + +/* Update A(i,i+1:n) */ + + i__2 = *n - i__; + sgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + ( + i__ + 1) * a_dim1], lda); + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * + a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[ + i__ + (i__ + 1) * a_dim1], lda); + +/* Generate reflection P(i) to annihilate A(i,i+2:n) */ + + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + slarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + f2cmin( + i__3,*n) * a_dim1], lda, &taup[i__]); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + a[i__ + (i__ + 1) * a_dim1] = 1.f; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], + lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__; + sgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], + ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[ + i__ * x_dim1 + 1], &c__1); + i__2 = *m - i__; + sgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b16, &x[i__ * x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + sscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + } +/* L10: */ + } + } else { + +/* Reduce to lower bidiagonal form */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i,i:n) */ + + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, + &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1], + lda); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + sgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], + lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1], + lda); + +/* Generate reflection P(i) to annihilate A(i,i+1:n) */ + + i__2 = *n - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + f2cmin(i__3,*n) * + a_dim1], lda, &taup[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *m) { + a[i__ + i__ * a_dim1] = 1.f; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__ + 1; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ * + a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, & + x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], + ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * + x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + + 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * + x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + sscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + +/* Update A(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + + 1 + i__ * a_dim1], &c__1); + i__2 = *m - i__; + sgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[ + i__ + 1 + i__ * a_dim1], &c__1); + +/* Generate reflection Q(i) to annihilate A(i+2:m,i) */ + + i__2 = *m - i__; +/* Computing MIN */ + i__3 = i__ + 2; + slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[f2cmin(i__3,*m) + + i__ * a_dim1], &c__1, &tauq[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.f; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, + &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ + i__ * y_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ + i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__; + sgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], + ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ + i__ * y_dim1 + 1], &c__1); + i__2 = *n - i__; + sgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 + + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + + 1 + i__ * y_dim1], &c__1); + i__2 = *n - i__; + sscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + } +/* L20: */ + } + } + return 0; + +/* End of SLABRD */ + +} /* slabrd_ */ + diff --git a/lapack-netlib/SRC/slacn2.c b/lapack-netlib/SRC/slacn2.c new file mode 100644 index 000000000..1c65ad147 --- /dev/null +++ b/lapack-netlib/SRC/slacn2.c @@ -0,0 +1,700 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matr +ix-vector products. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLACN2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) */ + +/* INTEGER KASE, N */ +/* REAL EST */ +/* INTEGER ISGN( * ), ISAVE( 3 ) */ +/* REAL V( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLACN2 estimates the 1-norm of a square, real matrix A. */ +/* > Reverse communication is used for evaluating matrix-vector products. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (N) */ +/* > On the final return, V = A*W, where EST = norm(V)/norm(W) */ +/* > (W is not returned). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > On an intermediate return, X should be overwritten by */ +/* > A * X, if KASE=1, */ +/* > A**T * X, if KASE=2, */ +/* > and SLACN2 must be re-called with all the other parameters */ +/* > unchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISGN */ +/* > \verbatim */ +/* > ISGN is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EST */ +/* > \verbatim */ +/* > EST is REAL */ +/* > On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */ +/* > unchanged from the previous call to SLACN2. */ +/* > On exit, EST is an estimate (a lower bound) for norm(A). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] KASE */ +/* > \verbatim */ +/* > KASE is INTEGER */ +/* > On the initial call to SLACN2, KASE should be 0. */ +/* > On an intermediate return, KASE will be 1 or 2, indicating */ +/* > whether X should be overwritten by A * X or A**T * X. */ +/* > On the final return from SLACN2, KASE will again be 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISAVE */ +/* > \verbatim */ +/* > ISAVE is INTEGER array, dimension (3) */ +/* > ISAVE is used to save variables between calls to SLACN2 */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Originally named SONEST, dated March 16, 1988. */ +/* > */ +/* > This is a thread safe version of SLACON, which uses the array ISAVE */ +/* > in place of a SAVE statement, as follows: */ +/* > */ +/* > SLACON SLACN2 */ +/* > JUMP ISAVE(1) */ +/* > J ISAVE(2) */ +/* > ITER ISAVE(3) */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham, University of Manchester */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > N.J. Higham, "FORTRAN codes for estimating the one-norm of */ +/* > a real or complex matrix, with applications to condition estimation", */ +/* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slacn2_(integer *n, real *v, real *x, integer *isgn, + real *est, integer *kase, integer *isave) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + real temp; + integer i__, jlast; + extern real sasum_(integer *, real *, integer *); + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + extern integer isamax_(integer *, real *, integer *); + real altsgn, estold; + + +/* -- 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 */ + --isave; + --isgn; + --x; + --v; + + /* Function Body */ + if (*kase == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 1.f / (real) (*n); +/* L10: */ + } + *kase = 1; + isave[1] = 1; + return 0; + } + + switch (isave[1]) { + case 1: goto L20; + case 2: goto L40; + case 3: goto L70; + case 4: goto L110; + case 5: goto L140; + } + +/* ................ ENTRY (ISAVE( 1 ) = 1) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ + +L20: + if (*n == 1) { + v[1] = x[1]; + *est = abs(v[1]); +/* ... QUIT */ + goto L150; + } + *est = sasum_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = r_sign(&c_b11, &x[i__]); + isgn[i__] = i_nint(&x[i__]); +/* L30: */ + } + *kase = 2; + isave[1] = 2; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 2) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L40: + isave[2] = isamax_(n, &x[1], &c__1); + isave[3] = 2; + +/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ + +L50: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 0.f; +/* L60: */ + } + x[isave[2]] = 1.f; + *kase = 1; + isave[1] = 3; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + scopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = sasum_(n, &v[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = r_sign(&c_b11, &x[i__]); + if (i_nint(&r__1) != isgn[i__]) { + goto L90; + } +/* L80: */ + } +/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ + goto L120; + +L90: +/* TEST FOR CYCLING. */ + if (*est <= estold) { + goto L120; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = r_sign(&c_b11, &x[i__]); + isgn[i__] = i_nint(&x[i__]); +/* L100: */ + } + *kase = 2; + isave[1] = 4; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 4) */ +/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L110: + jlast = isave[2]; + isave[2] = isamax_(n, &x[1], &c__1); + if (x[jlast] != (r__1 = x[isave[2]], abs(r__1)) && isave[3] < 5) { + ++isave[3]; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L120: + altsgn = 1.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f); + altsgn = -altsgn; +/* L130: */ + } + *kase = 1; + isave[1] = 5; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L140: + temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f; + if (temp > *est) { + scopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L150: + *kase = 0; + return 0; + +/* End of SLACN2 */ + +} /* slacn2_ */ + diff --git a/lapack-netlib/SRC/slacon.c b/lapack-netlib/SRC/slacon.c new file mode 100644 index 000000000..795a8a318 --- /dev/null +++ b/lapack-netlib/SRC/slacon.c @@ -0,0 +1,679 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matr +ix-vector products. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLACON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE ) */ + +/* INTEGER KASE, N */ +/* REAL EST */ +/* INTEGER ISGN( * ) */ +/* REAL V( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLACON estimates the 1-norm of a square, real matrix A. */ +/* > Reverse communication is used for evaluating matrix-vector products. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (N) */ +/* > On the final return, V = A*W, where EST = norm(V)/norm(W) */ +/* > (W is not returned). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > On an intermediate return, X should be overwritten by */ +/* > A * X, if KASE=1, */ +/* > A**T * X, if KASE=2, */ +/* > and SLACON must be re-called with all the other parameters */ +/* > unchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISGN */ +/* > \verbatim */ +/* > ISGN is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EST */ +/* > \verbatim */ +/* > EST is REAL */ +/* > On entry with KASE = 1 or 2 and JUMP = 3, EST should be */ +/* > unchanged from the previous call to SLACON. */ +/* > On exit, EST is an estimate (a lower bound) for norm(A). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] KASE */ +/* > \verbatim */ +/* > KASE is INTEGER */ +/* > On the initial call to SLACON, KASE should be 0. */ +/* > On an intermediate return, KASE will be 1 or 2, indicating */ +/* > whether X should be overwritten by A * X or A**T * X. */ +/* > On the final return from SLACON, KASE will again be 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham, University of Manchester. \n */ +/* > Originally named SONEST, dated March 16, 1988. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > N.J. Higham, "FORTRAN codes for estimating the one-norm of */ +/* > a real or complex matrix, with applications to condition estimation", */ +/* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn, + real *est, integer *kase) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + static integer iter; + static real temp; + static integer jump, i__, j, jlast; + extern real sasum_(integer *, real *, integer *); + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + extern integer isamax_(integer *, real *, integer *); + static real altsgn, estold; + + +/* -- 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 */ + --isgn; + --x; + --v; + + /* Function Body */ + if (*kase == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 1.f / (real) (*n); +/* L10: */ + } + *kase = 1; + jump = 1; + return 0; + } + + switch (jump) { + case 1: goto L20; + case 2: goto L40; + case 3: goto L70; + case 4: goto L110; + case 5: goto L140; + } + +/* ................ ENTRY (JUMP = 1) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ + +L20: + if (*n == 1) { + v[1] = x[1]; + *est = abs(v[1]); +/* ... QUIT */ + goto L150; + } + *est = sasum_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = r_sign(&c_b11, &x[i__]); + isgn[i__] = i_nint(&x[i__]); +/* L30: */ + } + *kase = 2; + jump = 2; + return 0; + +/* ................ ENTRY (JUMP = 2) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L40: + j = isamax_(n, &x[1], &c__1); + iter = 2; + +/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ + +L50: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 0.f; +/* L60: */ + } + x[j] = 1.f; + *kase = 1; + jump = 3; + return 0; + +/* ................ ENTRY (JUMP = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + scopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = sasum_(n, &v[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = r_sign(&c_b11, &x[i__]); + if (i_nint(&r__1) != isgn[i__]) { + goto L90; + } +/* L80: */ + } +/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ + goto L120; + +L90: +/* TEST FOR CYCLING. */ + if (*est <= estold) { + goto L120; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = r_sign(&c_b11, &x[i__]); + isgn[i__] = i_nint(&x[i__]); +/* L100: */ + } + *kase = 2; + jump = 4; + return 0; + +/* ................ ENTRY (JUMP = 4) */ +/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L110: + jlast = j; + j = isamax_(n, &x[1], &c__1); + if (x[jlast] != (r__1 = x[j], abs(r__1)) && iter < 5) { + ++iter; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L120: + altsgn = 1.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f); + altsgn = -altsgn; +/* L130: */ + } + *kase = 1; + jump = 5; + return 0; + +/* ................ ENTRY (JUMP = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L140: + temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f; + if (temp > *est) { + scopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L150: + *kase = 0; + return 0; + +/* End of SLACON */ + +} /* slacon_ */ + diff --git a/lapack-netlib/SRC/slacpy.c b/lapack-netlib/SRC/slacpy.c new file mode 100644 index 000000000..3c5785aca --- /dev/null +++ b/lapack-netlib/SRC/slacpy.c @@ -0,0 +1,556 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLACPY copies all or part of one two-dimensional array to another. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLACPY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, LDB, M, N */ +/* REAL A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLACPY copies all or part of a two-dimensional matrix A to another */ +/* > matrix B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies the part of the matrix A to be copied to B. */ +/* > = 'U': Upper triangular part */ +/* > = 'L': Lower triangular part */ +/* > Otherwise: All of the matrix A */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The m by n matrix A. If UPLO = 'U', only the upper triangle */ +/* > or trapezoid is accessed; if UPLO = 'L', only the lower */ +/* > triangle or trapezoid is accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On exit, B = A in the locations specified by UPLO. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slacpy_(char *uplo, integer *m, integer *n, real *a, + integer *lda, real *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(uplo, "L")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +/* L50: */ + } +/* L60: */ + } + } + return 0; + +/* End of SLACPY */ + +} /* slacpy_ */ + diff --git a/lapack-netlib/SRC/sladiv.c b/lapack-netlib/SRC/sladiv.c new file mode 100644 index 000000000..fc135e45f --- /dev/null +++ b/lapack-netlib/SRC/sladiv.c @@ -0,0 +1,621 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLADIV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLADIV( A, B, C, D, P, Q ) */ + +/* REAL A, B, C, D, P, Q */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLADIV performs complex division in real arithmetic */ +/* > */ +/* > a + i*b */ +/* > p + i*q = --------- */ +/* > c + i*d */ +/* > */ +/* > The algorithm is due to Michael Baudin and Robert L. Smith */ +/* > and can be found in the paper */ +/* > "A Robust Complex Division in Scilab" */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL */ +/* > The scalars a, b, c, and d in the above expression. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] P */ +/* > \verbatim */ +/* > P is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL */ +/* > The scalars p and q in the above expression. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date January 2013 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int sladiv_(real *a, real *b, real *c__, real *d__, real *p, + real *q) +{ + /* System generated locals */ + real r__1, r__2; + + /* Local variables */ + real s, aa, ab, bb, cc, cd, dd, be, un, ov; + extern real slamch_(char *); + extern /* Subroutine */ int sladiv1_(real *, real *, real *, real *, real + *, real *); + real eps; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* January 2013 */ + + +/* ===================================================================== */ + + + + aa = *a; + bb = *b; + cc = *c__; + dd = *d__; +/* Computing MAX */ + r__1 = abs(*a), r__2 = abs(*b); + ab = f2cmax(r__1,r__2); +/* Computing MAX */ + r__1 = abs(*c__), r__2 = abs(*d__); + cd = f2cmax(r__1,r__2); + s = 1.f; + ov = slamch_("Overflow threshold"); + un = slamch_("Safe minimum"); + eps = slamch_("Epsilon"); + be = 2.f / (eps * eps); + if (ab >= ov * .5f) { + aa *= .5f; + bb *= .5f; + s *= 2.f; + } + if (cd >= ov * .5f) { + cc *= .5f; + dd *= .5f; + s *= .5f; + } + if (ab <= un * 2.f / eps) { + aa *= be; + bb *= be; + s /= be; + } + if (cd <= un * 2.f / eps) { + cc *= be; + dd *= be; + s *= be; + } + if (abs(*d__) <= abs(*c__)) { + sladiv1_(&aa, &bb, &cc, &dd, p, q); + } else { + sladiv1_(&bb, &aa, &dd, &cc, p, q); + *q = -(*q); + } + *p *= s; + *q *= s; + + return 0; + +/* End of SLADIV */ + +} /* sladiv_ */ + +/* > \ingroup realOTHERauxiliary */ +/* Subroutine */ int sladiv1_(real *a, real *b, real *c__, real *d__, real *p, + real *q) +{ + real r__, t; + extern real sladiv2_(real *, real *, real *, real *, real *, real *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* January 2013 */ + + +/* ===================================================================== */ + + + + r__ = *d__ / *c__; + t = 1.f / (*c__ + *d__ * r__); + *p = sladiv2_(a, b, c__, d__, &r__, &t); + *a = -(*a); + *q = sladiv2_(b, a, c__, d__, &r__, &t); + + return 0; + +/* End of SLADIV1 */ + +} /* sladiv1_ */ + +/* > \ingroup realOTHERauxiliary */ +real sladiv2_(real *a, real *b, real *c__, real *d__, real *r__, real *t) +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + real br; + + +/* -- 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..-- */ +/* January 2013 */ + + +/* ===================================================================== */ + + + + if (*r__ != 0.f) { + br = *b * *r__; + if (br != 0.f) { + ret_val = (*a + br) * *t; + } else { + ret_val = *a * *t + *b * *t * *r__; + } + } else { + ret_val = (*a + *d__ * (*b / *c__)) * *t; + } + + return ret_val; + +/* End of SLADIV */ + +} /* sladiv2_ */ + diff --git a/lapack-netlib/SRC/slae2.c b/lapack-netlib/SRC/slae2.c new file mode 100644 index 000000000..285a9c2b0 --- /dev/null +++ b/lapack-netlib/SRC/slae2.c @@ -0,0 +1,566 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAE2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAE2( A, B, C, RT1, RT2 ) */ + +/* REAL A, B, C, RT1, RT2 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix */ +/* > [ A B ] */ +/* > [ B C ]. */ +/* > On return, RT1 is the eigenvalue of larger absolute value, and RT2 */ +/* > is the eigenvalue of smaller absolute value. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL */ +/* > The (1,1) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL */ +/* > The (1,2) and (2,1) elements of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > The (2,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1 */ +/* > \verbatim */ +/* > RT1 is REAL */ +/* > The eigenvalue of larger absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2 */ +/* > \verbatim */ +/* > RT2 is REAL */ +/* > The eigenvalue of smaller absolute value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > RT1 is accurate to a few ulps barring over/underflow. */ +/* > */ +/* > RT2 may be inaccurate if there is massive cancellation in the */ +/* > determinant A*C-B*B; higher precision or correctly rounded or */ +/* > correctly truncated arithmetic would be needed to compute RT2 */ +/* > accurately in all cases. */ +/* > */ +/* > Overflow is possible only if RT1 is within a factor of 5 of overflow. */ +/* > Underflow is harmless if the input data is 0 or exceeds */ +/* > underflow_threshold / macheps. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slae2_(real *a, real *b, real *c__, real *rt1, real *rt2) +{ + /* System generated locals */ + real r__1; + + /* Local variables */ + real acmn, acmx, ab, df, tb, sm, rt, adf; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Compute the eigenvalues */ + + sm = *a + *c__; + df = *a - *c__; + adf = abs(df); + tb = *b + *b; + ab = abs(tb); + if (abs(*a) > abs(*c__)) { + acmx = *a; + acmn = *c__; + } else { + acmx = *c__; + acmn = *a; + } + if (adf > ab) { +/* Computing 2nd power */ + r__1 = ab / adf; + rt = adf * sqrt(r__1 * r__1 + 1.f); + } else if (adf < ab) { +/* Computing 2nd power */ + r__1 = adf / ab; + rt = ab * sqrt(r__1 * r__1 + 1.f); + } else { + +/* Includes case AB=ADF=0 */ + + rt = ab * sqrt(2.f); + } + if (sm < 0.f) { + *rt1 = (sm - rt) * .5f; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else if (sm > 0.f) { + *rt1 = (sm + rt) * .5f; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else { + +/* Includes case RT1 = RT2 = 0 */ + + *rt1 = rt * .5f; + *rt2 = rt * -.5f; + } + return 0; + +/* End of SLAE2 */ + +} /* slae2_ */ + diff --git a/lapack-netlib/SRC/slaebz.c b/lapack-netlib/SRC/slaebz.c new file mode 100644 index 000000000..c236ba2ad --- /dev/null +++ b/lapack-netlib/SRC/slaebz.c @@ -0,0 +1,1099 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less + than or equal to a given value, and performs other tasks required by the routine sstebz. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAEBZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, */ +/* RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, */ +/* NAB, WORK, IWORK, INFO ) */ + +/* INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX */ +/* REAL ABSTOL, PIVMIN, RELTOL */ +/* INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) */ +/* REAL AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAEBZ contains the iteration loops which compute and use the */ +/* > function N(w), which is the count of eigenvalues of a symmetric */ +/* > tridiagonal matrix T less than or equal to its argument w. It */ +/* > performs a choice of two types of loops: */ +/* > */ +/* > IJOB=1, followed by */ +/* > IJOB=2: It takes as input a list of intervals and returns a list of */ +/* > sufficiently small intervals whose union contains the same */ +/* > eigenvalues as the union of the original intervals. */ +/* > The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */ +/* > The output interval (AB(j,1),AB(j,2)] will contain */ +/* > eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */ +/* > */ +/* > IJOB=3: It performs a binary search in each input interval */ +/* > (AB(j,1),AB(j,2)] for a point w(j) such that */ +/* > N(w(j))=NVAL(j), and uses C(j) as the starting point of */ +/* > the search. If such a w(j) is found, then on output */ +/* > AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output */ +/* > (AB(j,1),AB(j,2)] will be a small interval containing the */ +/* > point where N(w) jumps through NVAL(j), unless that point */ +/* > lies outside the initial interval. */ +/* > */ +/* > Note that the intervals are in all cases half-open intervals, */ +/* > i.e., of the form (a,b] , which includes b but not a . */ +/* > */ +/* > To avoid underflow, the matrix should be scaled so that its largest */ +/* > element is no greater than overflow**(1/2) * underflow**(1/4) */ +/* > in absolute value. To assure the most accurate computation */ +/* > of small eigenvalues, the matrix should be scaled to be */ +/* > not much smaller than that, either. */ +/* > */ +/* > See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* > Matrix", Report CS41, Computer Science Dept., Stanford */ +/* > University, July 21, 1966 */ +/* > */ +/* > Note: the arguments are, in general, *not* checked for unreasonable */ +/* > values. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies what is to be done: */ +/* > = 1: Compute NAB for the initial intervals. */ +/* > = 2: Perform bisection iteration to find eigenvalues of T. */ +/* > = 3: Perform bisection iteration to invert N(w), i.e., */ +/* > to find a point which has a specified number of */ +/* > eigenvalues of T to its left. */ +/* > Other values will cause SLAEBZ to return with INFO=-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NITMAX */ +/* > \verbatim */ +/* > NITMAX is INTEGER */ +/* > The maximum number of "levels" of bisection to be */ +/* > performed, i.e., an interval of width W will not be made */ +/* > smaller than 2^(-NITMAX) * W. If not all intervals */ +/* > have converged after NITMAX iterations, then INFO is set */ +/* > to the number of non-converged intervals. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension n of the tridiagonal matrix T. It must be at */ +/* > least 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MMAX */ +/* > \verbatim */ +/* > MMAX is INTEGER */ +/* > The maximum number of intervals. If more than MMAX intervals */ +/* > are generated, then SLAEBZ will quit with INFO=MMAX+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MINP */ +/* > \verbatim */ +/* > MINP is INTEGER */ +/* > The initial number of intervals. It may not be greater than */ +/* > MMAX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NBMIN */ +/* > \verbatim */ +/* > NBMIN is INTEGER */ +/* > The smallest number of intervals that should be processed */ +/* > using a vector loop. If zero, then only the scalar loop */ +/* > will be used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ABSTOL */ +/* > \verbatim */ +/* > ABSTOL is REAL */ +/* > The minimum (absolute) width of an interval. When an */ +/* > interval is narrower than ABSTOL, or than RELTOL times the */ +/* > larger (in magnitude) endpoint, then it is considered to be */ +/* > sufficiently small, i.e., converged. This must be at least */ +/* > zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RELTOL */ +/* > \verbatim */ +/* > RELTOL is REAL */ +/* > The minimum relative width of an interval. When an interval */ +/* > is narrower than ABSTOL, or than RELTOL times the larger (in */ +/* > magnitude) endpoint, then it is considered to be */ +/* > sufficiently small, i.e., converged. Note: this should */ +/* > always be at least radix*machine epsilon. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum absolute value of a "pivot" in the Sturm */ +/* > sequence loop. */ +/* > This must be at least f2cmax |e(j)**2|*safe_min and at */ +/* > least safe_min, where safe_min is at least */ +/* > the smallest number that can divide one without overflow. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > The offdiagonal elements of the tridiagonal matrix T in */ +/* > positions 1 through N-1. E(N) is arbitrary. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E2 */ +/* > \verbatim */ +/* > E2 is REAL array, dimension (N) */ +/* > The squares of the offdiagonal elements of the tridiagonal */ +/* > matrix T. E2(N) is ignored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] NVAL */ +/* > \verbatim */ +/* > NVAL is INTEGER array, dimension (MINP) */ +/* > If IJOB=1 or 2, not referenced. */ +/* > If IJOB=3, the desired values of N(w). The elements of NVAL */ +/* > will be reordered to correspond with the intervals in AB. */ +/* > Thus, NVAL(j) on output will not, in general be the same as */ +/* > NVAL(j) on input, but it will correspond with the interval */ +/* > (AB(j,1),AB(j,2)] on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (MMAX,2) */ +/* > The endpoints of the intervals. AB(j,1) is a(j), the left */ +/* > endpoint of the j-th interval, and AB(j,2) is b(j), the */ +/* > right endpoint of the j-th interval. The input intervals */ +/* > will, in general, be modified, split, and reordered by the */ +/* > calculation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (MMAX) */ +/* > If IJOB=1, ignored. */ +/* > If IJOB=2, workspace. */ +/* > If IJOB=3, then on input C(j) should be initialized to the */ +/* > first search point in the binary search. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] MOUT */ +/* > \verbatim */ +/* > MOUT is INTEGER */ +/* > If IJOB=1, the number of eigenvalues in the intervals. */ +/* > If IJOB=2 or 3, the number of intervals output. */ +/* > If IJOB=3, MOUT will equal MINP. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] NAB */ +/* > \verbatim */ +/* > NAB is INTEGER array, dimension (MMAX,2) */ +/* > If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */ +/* > If IJOB=2, then on input, NAB(i,j) should be set. It must */ +/* > satisfy the condition: */ +/* > N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */ +/* > which means that in interval i only eigenvalues */ +/* > NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, */ +/* > NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with */ +/* > IJOB=1. */ +/* > On output, NAB(i,j) will contain */ +/* > f2cmax(na(k),f2cmin(nb(k),N(AB(i,j)))), where k is the index of */ +/* > the input interval that the output interval */ +/* > (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */ +/* > the input values of NAB(k,1) and NAB(k,2). */ +/* > If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */ +/* > unless N(w) > NVAL(i) for all search points w , in which */ +/* > case NAB(i,1) will not be modified, i.e., the output */ +/* > value will be the same as the input value (modulo */ +/* > reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */ +/* > for all search points w , in which case NAB(i,2) will */ +/* > not be modified. Normally, NAB should be set to some */ +/* > distinctive value(s) before SLAEBZ is called. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MMAX) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MMAX) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: All intervals converged. */ +/* > = 1--MMAX: The last INFO intervals did not converge. */ +/* > = MMAX+1: More than MMAX intervals were generated. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is intended to be called only by other LAPACK */ +/* > routines, thus the interface is less user-friendly. It is intended */ +/* > for two purposes: */ +/* > */ +/* > (a) finding eigenvalues. In this case, SLAEBZ should have one or */ +/* > more initial intervals set up in AB, and SLAEBZ should be called */ +/* > with IJOB=1. This sets up NAB, and also counts the eigenvalues. */ +/* > Intervals with no eigenvalues would usually be thrown out at */ +/* > this point. Also, if not all the eigenvalues in an interval i */ +/* > are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */ +/* > For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */ +/* > eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX */ +/* > no smaller than the value of MOUT returned by the call with */ +/* > IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */ +/* > through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */ +/* > tolerance specified by ABSTOL and RELTOL. */ +/* > */ +/* > (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */ +/* > In this case, start with a Gershgorin interval (a,b). Set up */ +/* > AB to contain 2 search intervals, both initially (a,b). One */ +/* > NVAL element should contain f-1 and the other should contain l */ +/* > , while C should contain a and b, resp. NAB(i,1) should be -1 */ +/* > and NAB(i,2) should be N+1, to flag an error if the desired */ +/* > interval does not lie in (a,b). SLAEBZ is then called with */ +/* > IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- */ +/* > j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */ +/* > if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */ +/* > >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and */ +/* > N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and */ +/* > w(l-r)=...=w(l+k) are handled similarly. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n, + integer *mmax, integer *minp, integer *nbmin, real *abstol, real * + reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval, + real *ab, real *c__, integer *mout, integer *nab, real *work, integer + *iwork, integer *info) +{ + /* System generated locals */ + integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4, + i__5, i__6; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + integer itmp1, itmp2, j, kfnew, klnew, kf, ji, kl, jp, jit; + real tmp1, tmp2; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Check for Errors */ + + /* Parameter adjustments */ + nab_dim1 = *mmax; + nab_offset = 1 + nab_dim1 * 1; + nab -= nab_offset; + ab_dim1 = *mmax; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --d__; + --e; + --e2; + --nval; + --c__; + --work; + --iwork; + + /* Function Body */ + *info = 0; + if (*ijob < 1 || *ijob > 3) { + *info = -1; + return 0; + } + +/* Initialize NAB */ + + if (*ijob == 1) { + +/* Compute the number of eigenvalues in the initial intervals. */ + + *mout = 0; + i__1 = *minp; + for (ji = 1; ji <= i__1; ++ji) { + for (jp = 1; jp <= 2; ++jp) { + tmp1 = d__[1] - ab[ji + jp * ab_dim1]; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + nab[ji + jp * nab_dim1] = 0; + if (tmp1 <= 0.f) { + nab[ji + jp * nab_dim1] = 1; + } + + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1]; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + if (tmp1 <= 0.f) { + ++nab[ji + jp * nab_dim1]; + } +/* L10: */ + } +/* L20: */ + } + *mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1]; +/* L30: */ + } + return 0; + } + +/* Initialize for loop */ + +/* KF and KL have the following meaning: */ +/* Intervals 1,...,KF-1 have converged. */ +/* Intervals KF,...,KL still need to be refined. */ + + kf = 1; + kl = *minp; + +/* If IJOB=2, initialize C. */ +/* If IJOB=3, use the user-supplied starting point. */ + + if (*ijob == 2) { + i__1 = *minp; + for (ji = 1; ji <= i__1; ++ji) { + c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f; +/* L40: */ + } + } + +/* Iteration loop */ + + i__1 = *nitmax; + for (jit = 1; jit <= i__1; ++jit) { + +/* Loop over intervals */ + + if (kl - kf + 1 >= *nbmin && *nbmin > 0) { + +/* Begin of Parallel Version of the loop */ + + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + +/* Compute N(c), the number of eigenvalues less than c */ + + work[ji] = d__[1] - c__[ji]; + iwork[ji] = 0; + if (work[ji] <= *pivmin) { + iwork[ji] = 1; +/* Computing MIN */ + r__1 = work[ji], r__2 = -(*pivmin); + work[ji] = f2cmin(r__1,r__2); + } + + i__3 = *n; + for (j = 2; j <= i__3; ++j) { + work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji]; + if (work[ji] <= *pivmin) { + ++iwork[ji]; +/* Computing MIN */ + r__1 = work[ji], r__2 = -(*pivmin); + work[ji] = f2cmin(r__1,r__2); + } +/* L50: */ + } +/* L60: */ + } + + if (*ijob <= 2) { + +/* IJOB=2: Choose all intervals containing eigenvalues. */ + + klnew = kl; + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + +/* Insure that N(w) is monotone */ + +/* Computing MIN */ +/* Computing MAX */ + i__5 = nab[ji + nab_dim1], i__6 = iwork[ji]; + i__3 = nab[ji + (nab_dim1 << 1)], i__4 = f2cmax(i__5,i__6); + iwork[ji] = f2cmin(i__3,i__4); + +/* Update the Queue -- add intervals if both halves */ +/* contain eigenvalues. */ + + if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) { + +/* No eigenvalue in the upper interval: */ +/* just use the lower interval. */ + + ab[ji + (ab_dim1 << 1)] = c__[ji]; + + } else if (iwork[ji] == nab[ji + nab_dim1]) { + +/* No eigenvalue in the lower interval: */ +/* just use the upper interval. */ + + ab[ji + ab_dim1] = c__[ji]; + } else { + ++klnew; + if (klnew <= *mmax) { + +/* Eigenvalue in both intervals -- add upper to */ +/* queue. */ + + ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << + 1)]; + nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 + << 1)]; + ab[klnew + ab_dim1] = c__[ji]; + nab[klnew + nab_dim1] = iwork[ji]; + ab[ji + (ab_dim1 << 1)] = c__[ji]; + nab[ji + (nab_dim1 << 1)] = iwork[ji]; + } else { + *info = *mmax + 1; + } + } +/* L70: */ + } + if (*info != 0) { + return 0; + } + kl = klnew; + } else { + +/* IJOB=3: Binary search. Keep only the interval containing */ +/* w s.t. N(w) = NVAL */ + + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + if (iwork[ji] <= nval[ji]) { + ab[ji + ab_dim1] = c__[ji]; + nab[ji + nab_dim1] = iwork[ji]; + } + if (iwork[ji] >= nval[ji]) { + ab[ji + (ab_dim1 << 1)] = c__[ji]; + nab[ji + (nab_dim1 << 1)] = iwork[ji]; + } +/* L80: */ + } + } + + } else { + +/* End of Parallel Version of the loop */ + +/* Begin of Serial Version of the loop */ + + klnew = kl; + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + +/* Compute N(w), the number of eigenvalues less than w */ + + tmp1 = c__[ji]; + tmp2 = d__[1] - tmp1; + itmp1 = 0; + if (tmp2 <= *pivmin) { + itmp1 = 1; +/* Computing MIN */ + r__1 = tmp2, r__2 = -(*pivmin); + tmp2 = f2cmin(r__1,r__2); + } + + i__3 = *n; + for (j = 2; j <= i__3; ++j) { + tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1; + if (tmp2 <= *pivmin) { + ++itmp1; +/* Computing MIN */ + r__1 = tmp2, r__2 = -(*pivmin); + tmp2 = f2cmin(r__1,r__2); + } +/* L90: */ + } + + if (*ijob <= 2) { + +/* IJOB=2: Choose all intervals containing eigenvalues. */ + +/* Insure that N(w) is monotone */ + +/* Computing MIN */ +/* Computing MAX */ + i__5 = nab[ji + nab_dim1]; + i__3 = nab[ji + (nab_dim1 << 1)], i__4 = f2cmax(i__5,itmp1); + itmp1 = f2cmin(i__3,i__4); + +/* Update the Queue -- add intervals if both halves */ +/* contain eigenvalues. */ + + if (itmp1 == nab[ji + (nab_dim1 << 1)]) { + +/* No eigenvalue in the upper interval: */ +/* just use the lower interval. */ + + ab[ji + (ab_dim1 << 1)] = tmp1; + + } else if (itmp1 == nab[ji + nab_dim1]) { + +/* No eigenvalue in the lower interval: */ +/* just use the upper interval. */ + + ab[ji + ab_dim1] = tmp1; + } else if (klnew < *mmax) { + +/* Eigenvalue in both intervals -- add upper to queue. */ + + ++klnew; + ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)]; + nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 << + 1)]; + ab[klnew + ab_dim1] = tmp1; + nab[klnew + nab_dim1] = itmp1; + ab[ji + (ab_dim1 << 1)] = tmp1; + nab[ji + (nab_dim1 << 1)] = itmp1; + } else { + *info = *mmax + 1; + return 0; + } + } else { + +/* IJOB=3: Binary search. Keep only the interval */ +/* containing w s.t. N(w) = NVAL */ + + if (itmp1 <= nval[ji]) { + ab[ji + ab_dim1] = tmp1; + nab[ji + nab_dim1] = itmp1; + } + if (itmp1 >= nval[ji]) { + ab[ji + (ab_dim1 << 1)] = tmp1; + nab[ji + (nab_dim1 << 1)] = itmp1; + } + } +/* L100: */ + } + kl = klnew; + + } + +/* Check for convergence */ + + kfnew = kf; + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + tmp1 = (r__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], abs( + r__1)); +/* Computing MAX */ + r__3 = (r__1 = ab[ji + (ab_dim1 << 1)], abs(r__1)), r__4 = (r__2 = + ab[ji + ab_dim1], abs(r__2)); + tmp2 = f2cmax(r__3,r__4); +/* Computing MAX */ + r__1 = f2cmax(*abstol,*pivmin), r__2 = *reltol * tmp2; + if (tmp1 < f2cmax(r__1,r__2) || nab[ji + nab_dim1] >= nab[ji + ( + nab_dim1 << 1)]) { + +/* Converged -- Swap with position KFNEW, */ +/* then increment KFNEW */ + + if (ji > kfnew) { + tmp1 = ab[ji + ab_dim1]; + tmp2 = ab[ji + (ab_dim1 << 1)]; + itmp1 = nab[ji + nab_dim1]; + itmp2 = nab[ji + (nab_dim1 << 1)]; + ab[ji + ab_dim1] = ab[kfnew + ab_dim1]; + ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)]; + nab[ji + nab_dim1] = nab[kfnew + nab_dim1]; + nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)]; + ab[kfnew + ab_dim1] = tmp1; + ab[kfnew + (ab_dim1 << 1)] = tmp2; + nab[kfnew + nab_dim1] = itmp1; + nab[kfnew + (nab_dim1 << 1)] = itmp2; + if (*ijob == 3) { + itmp1 = nval[ji]; + nval[ji] = nval[kfnew]; + nval[kfnew] = itmp1; + } + } + ++kfnew; + } +/* L110: */ + } + kf = kfnew; + +/* Choose Midpoints */ + + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f; +/* L120: */ + } + +/* If no more intervals to refine, quit. */ + + if (kf > kl) { + goto L140; + } +/* L130: */ + } + +/* Converged */ + +L140: +/* Computing MAX */ + i__1 = kl + 1 - kf; + *info = f2cmax(i__1,0); + *mout = kl; + + return 0; + +/* End of SLAEBZ */ + +} /* slaebz_ */ + diff --git a/lapack-netlib/SRC/slaed0.c b/lapack-netlib/SRC/slaed0.c new file mode 100644 index 000000000..488bec5ff --- /dev/null +++ b/lapack-netlib/SRC/slaed0.c @@ -0,0 +1,876 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced +symmetric tridiagonal matrix using the divide and conquer method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, */ +/* WORK, IWORK, INFO ) */ + +/* INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ */ +/* INTEGER IWORK( * ) */ +/* REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED0 computes all eigenvalues and corresponding eigenvectors of a */ +/* > symmetric tridiagonal matrix using the divide and conquer method. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > = 0: Compute eigenvalues only. */ +/* > = 1: Compute eigenvectors of original dense symmetric matrix */ +/* > also. On entry, Q contains the orthogonal matrix used */ +/* > to reduce the original matrix to tridiagonal form. */ +/* > = 2: Compute eigenvalues and eigenvectors of tridiagonal */ +/* > matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QSIZ */ +/* > \verbatim */ +/* > QSIZ is INTEGER */ +/* > The dimension of the orthogonal matrix used to reduce */ +/* > the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ +/* > \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 REAL array, dimension (N) */ +/* > On entry, the main diagonal of the tridiagonal matrix. */ +/* > On exit, its eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > The off-diagonal elements of the tridiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ, N) */ +/* > On entry, Q must contain an N-by-N orthogonal matrix. */ +/* > If ICOMPQ = 0 Q is not referenced. */ +/* > If ICOMPQ = 1 On entry, Q is a subset of the columns of the */ +/* > orthogonal matrix used to reduce the full */ +/* > matrix to tridiagonal form corresponding to */ +/* > the subset of the full matrix which is being */ +/* > decomposed at this time. */ +/* > If ICOMPQ = 2 On entry, Q will be the identity matrix. */ +/* > On exit, Q contains the eigenvectors of the */ +/* > tridiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. If eigenvectors are */ +/* > desired, then LDQ >= f2cmax(1,N). In any case, LDQ >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] QSTORE */ +/* > \verbatim */ +/* > QSTORE is REAL array, dimension (LDQS, N) */ +/* > Referenced only when ICOMPQ = 1. Used to store parts of */ +/* > the eigenvector matrix when the updating matrix multiplies */ +/* > take place. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQS */ +/* > \verbatim */ +/* > LDQS is INTEGER */ +/* > The leading dimension of the array QSTORE. If ICOMPQ = 1, */ +/* > then LDQS >= f2cmax(1,N). In any case, LDQS >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, */ +/* > If ICOMPQ = 0 or 1, the dimension of WORK must be at least */ +/* > 1 + 3*N + 2*N*lg N + 3*N**2 */ +/* > ( lg( N ) = smallest integer k */ +/* > such that 2^k >= N ) */ +/* > If ICOMPQ = 2, the dimension of WORK must be at least */ +/* > 4*N + N**2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, */ +/* > If ICOMPQ = 0 or 1, the dimension of IWORK must be at least */ +/* > 6 + 6*N + 5*N*lg N. */ +/* > ( lg( N ) = smallest integer k */ +/* > such that 2^k >= N ) */ +/* > If ICOMPQ = 2, the dimension of IWORK must be at least */ +/* > 3 + 5*N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: The algorithm failed to compute 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 auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real + *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, + real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; + real r__1; + + /* Local variables */ + real temp; + integer curr, i__, j, k; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer iperm, indxq, iwrem; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer iqptr, tlvls; + extern /* Subroutine */ int slaed1_(integer *, real *, real *, integer *, + integer *, real *, integer *, real *, integer *, integer *), + slaed7_(integer *, integer *, integer *, integer *, integer *, + integer *, real *, real *, integer *, integer *, real *, integer * + , real *, integer *, integer *, integer *, integer *, integer *, + real *, real *, integer *, integer *); + integer iq, igivcl; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer igivnm, submat; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *); + integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt, smlsiz; + extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, + real *, integer *, real *, integer *); + integer lgn, msd2, smm1, spm1, spm2; + + +/* -- 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; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + qstore_dim1 = *ldqs; + qstore_offset = 1 + qstore_dim1 * 1; + qstore -= qstore_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 2) { + *info = -1; + } else if (*icompq == 1 && *qsiz < f2cmax(0,*n)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldq < f2cmax(1,*n)) { + *info = -7; + } else if (*ldqs < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED0", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + smlsiz = ilaenv_(&c__9, "SLAED0", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + +/* Determine the size and placement of the submatrices, and save in */ +/* the leading elements of IWORK. */ + + iwork[1] = *n; + subpbs = 1; + tlvls = 0; +L10: + if (iwork[subpbs] > smlsiz) { + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; +/* L20: */ + } + ++tlvls; + subpbs <<= 1; + goto L10; + } + i__1 = subpbs; + for (j = 2; j <= i__1; ++j) { + iwork[j] += iwork[j - 1]; +/* L30: */ + } + +/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */ +/* using rank-1 modifications (cuts). */ + + spm1 = subpbs - 1; + i__1 = spm1; + for (i__ = 1; i__ <= i__1; ++i__) { + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (r__1 = e[smm1], abs(r__1)); + d__[submat] -= (r__1 = e[smm1], abs(r__1)); +/* L40: */ + } + + indxq = (*n << 2) + 3; + if (*icompq != 2) { + +/* Set up workspaces for eigenvalues only/accumulate new vectors */ +/* routine */ + + temp = log((real) (*n)) / log(2.f); + lgn = (integer) temp; + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + iprmpt = indxq + *n + 1; + iperm = iprmpt + *n * lgn; + iqptr = iperm + *n * lgn; + igivpt = iqptr + *n + 2; + igivcl = igivpt + *n * lgn; + + igivnm = 1; + iq = igivnm + (*n << 1) * lgn; +/* Computing 2nd power */ + i__1 = *n; + iwrem = iq + i__1 * i__1 + 1; + +/* Initialize pointers */ + + i__1 = subpbs; + for (i__ = 0; i__ <= i__1; ++i__) { + iwork[iprmpt + i__] = 1; + iwork[igivpt + i__] = 1; +/* L50: */ + } + iwork[iqptr] = 1; + } + +/* Solve each submatrix eigenproblem at the bottom of the divide and */ +/* conquer tree. */ + + curr = 0; + i__1 = spm1; + for (i__ = 0; i__ <= i__1; ++i__) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 1] - iwork[i__]; + } + if (*icompq == 2) { + ssteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat + + submat * q_dim1], ldq, &work[1], info); + if (*info != 0) { + goto L130; + } + } else { + ssteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + + iwork[iqptr + curr]], &matsiz, &work[1], info); + if (*info != 0) { + goto L130; + } + if (*icompq == 1) { + sgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * + q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]], + &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1], + ldqs); + } +/* Computing 2nd power */ + i__2 = matsiz; + iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; + ++curr; + } + k = 1; + i__2 = iwork[i__ + 1]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j] = k; + ++k; +/* L60: */ + } +/* L70: */ + } + +/* Successively merge eigensystems of adjacent submatrices */ +/* into eigensystem for the corresponding larger matrix. */ + +/* while ( SUBPBS > 1 ) */ + + curlvl = 1; +L80: + if (subpbs > 1) { + spm2 = subpbs - 2; + i__1 = spm2; + for (i__ = 0; i__ <= i__1; i__ += 2) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[2]; + msd2 = iwork[1]; + curprb = 0; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 2] - iwork[i__]; + msd2 = matsiz / 2; + ++curprb; + } + +/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */ +/* into an eigensystem of size MATSIZ. */ +/* SLAED1 is used only for the full eigensystem of a tridiagonal */ +/* matrix. */ +/* SLAED7 handles the cases in which eigenvalues only or eigenvalues */ +/* and eigenvectors of a full symmetric matrix (which was reduced to */ +/* tridiagonal form) are desired. */ + + if (*icompq == 2) { + slaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], + ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & + msd2, &work[1], &iwork[subpbs + 1], info); + } else { + slaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[ + submat], &qstore[submat * qstore_dim1 + 1], ldqs, & + iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, & + work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm] + , &iwork[igivpt], &iwork[igivcl], &work[igivnm], & + work[iwrem], &iwork[subpbs + 1], info); + } + if (*info != 0) { + goto L130; + } + iwork[i__ / 2 + 1] = iwork[i__ + 2]; +/* L90: */ + } + subpbs /= 2; + ++curlvl; + goto L80; + } + +/* end while */ + +/* Re-merge the eigenvalues/vectors which were deflated at the final */ +/* merge step. */ + + if (*icompq == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + scopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + + 1], &c__1); +/* L100: */ + } + scopy_(n, &work[1], &c__1, &d__[1], &c__1); + } else if (*icompq == 2) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + scopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); +/* L110: */ + } + scopy_(n, &work[1], &c__1, &d__[1], &c__1); + slacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; +/* L120: */ + } + scopy_(n, &work[1], &c__1, &d__[1], &c__1); + } + goto L140; + +L130: + *info = submat * (*n + 1) + submat + matsiz - 1; + +L140: + return 0; + +/* End of SLAED0 */ + +} /* slaed0_ */ + diff --git a/lapack-netlib/SRC/slaed1.c b/lapack-netlib/SRC/slaed1.c new file mode 100644 index 000000000..2a107d21f --- /dev/null +++ b/lapack-netlib/SRC/slaed1.c @@ -0,0 +1,690 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED1 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification + by a rank-one symmetric matrix. Used when the original matrix is tridiagonal. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, */ +/* INFO ) */ + +/* INTEGER CUTPNT, INFO, LDQ, N */ +/* REAL RHO */ +/* INTEGER INDXQ( * ), IWORK( * ) */ +/* REAL D( * ), Q( LDQ, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED1 computes the updated eigensystem of a diagonal */ +/* > matrix after modification by a rank-one symmetric matrix. This */ +/* > routine is used only for the eigenproblem which requires all */ +/* > eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles */ +/* > the case in which eigenvalues only or eigenvalues and eigenvectors */ +/* > of a full symmetric matrix (which was reduced to tridiagonal form) */ +/* > are desired. */ +/* > */ +/* > T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) */ +/* > */ +/* > where Z = Q**T*u, u is a vector of length N with ones in the */ +/* > CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */ +/* > */ +/* > The eigenvectors of the original matrix are stored in Q, and the */ +/* > eigenvalues are in D. The algorithm consists of three stages: */ +/* > */ +/* > The first stage consists of deflating the size of the problem */ +/* > when there are multiple eigenvalues or if there is a zero in */ +/* > the Z vector. For each such occurrence the dimension of the */ +/* > secular equation problem is reduced by one. This stage is */ +/* > performed by the routine SLAED2. */ +/* > */ +/* > The second stage consists of calculating the updated */ +/* > eigenvalues. This is done by finding the roots of the secular */ +/* > equation via the routine SLAED4 (as called by SLAED3). */ +/* > This routine also calculates the eigenvectors of the current */ +/* > problem. */ +/* > */ +/* > The final stage consists of computing the updated eigenvectors */ +/* > directly using the updated eigenvalues. The eigenvectors for */ +/* > the current problem are multiplied with the eigenvectors from */ +/* > the overall problem. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the eigenvalues of the rank-1-perturbed matrix. */ +/* > On exit, the eigenvalues of the repaired matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, the eigenvectors of the rank-1-perturbed matrix. */ +/* > On exit, the eigenvectors of the repaired tridiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] INDXQ */ +/* > \verbatim */ +/* > INDXQ is INTEGER array, dimension (N) */ +/* > On entry, the permutation which separately sorts the two */ +/* > subproblems in D into ascending order. */ +/* > On exit, the permutation which will reintegrate the */ +/* > subproblems back into sorted order, */ +/* > i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The subdiagonal entry used to create the rank-1 modification. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CUTPNT */ +/* > \verbatim */ +/* > CUTPNT is INTEGER */ +/* > The location of the last eigenvalue in the leading sub-matrix. */ +/* > f2cmin(1,N) <= CUTPNT <= N/2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (4*N + N**2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER 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 = 1, an eigenvalue did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA \n */ +/* > Modified by Francoise Tisseur, University of Tennessee */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaed1_(integer *n, real *d__, real *q, integer *ldq, + integer *indxq, real *rho, integer *cutpnt, real *work, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + + /* Local variables */ + integer indx, i__, k, indxc, indxp; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer n1, n2; + extern /* Subroutine */ int slaed2_(integer *, integer *, integer *, real + *, real *, integer *, integer *, real *, real *, real *, real *, + real *, integer *, integer *, integer *, integer *, integer *), + slaed3_(integer *, integer *, integer *, real *, real *, integer * + , real *, real *, real *, integer *, integer *, real *, real *, + integer *); + integer idlmda, is, iw, iz; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slamrg_( + integer *, integer *, real *, integer *, integer *, integer *); + integer coltyp, iq2, cpp1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --indxq; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -1; + } else if (*ldq < f2cmax(1,*n)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MIN */ + i__1 = 1, i__2 = *n / 2; + if (f2cmin(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) { + *info = -7; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED1", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* The following values are integer pointers which indicate */ +/* the portion of the workspace */ +/* used by a particular array in SLAED2 and SLAED3. */ + + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq2 = iw + *n; + + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + + +/* Form the z-vector which consists of the last row of Q_1 and the */ +/* first row of Q_2. */ + + scopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1); + cpp1 = *cutpnt + 1; + i__1 = *n - *cutpnt; + scopy_(&i__1, &q[cpp1 + cpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1); + +/* Deflate eigenvalues. */ + + slaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[ + iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[ + indxc], &iwork[indxp], &iwork[coltyp], info); + + if (*info != 0) { + goto L20; + } + +/* Solve Secular Equation. */ + + if (k != 0) { + is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + + 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; + slaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], + &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[ + is], info); + if (*info != 0) { + goto L20; + } + +/* Prepare the INDXQ sorting permutation. */ + + n1 = k; + n2 = *n - k; + slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; +/* L10: */ + } + } + +L20: + return 0; + +/* End of SLAED1 */ + +} /* slaed1_ */ + diff --git a/lapack-netlib/SRC/slaed2.c b/lapack-netlib/SRC/slaed2.c new file mode 100644 index 000000000..b2c1362fb --- /dev/null +++ b/lapack-netlib/SRC/slaed2.c @@ -0,0 +1,994 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original + matrix is tridiagonal. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, */ +/* Q2, INDX, INDXC, INDXP, COLTYP, INFO ) */ + +/* INTEGER INFO, K, LDQ, N, N1 */ +/* REAL RHO */ +/* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), */ +/* $ INDXQ( * ) */ +/* REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), */ +/* $ W( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED2 merges the two sets of eigenvalues together into a single */ +/* > sorted set. Then it tries to deflate the size of the problem. */ +/* > There are two ways in which deflation can occur: when two or more */ +/* > eigenvalues are close together or if there is a tiny entry in the */ +/* > Z vector. For each such occurrence the order of the related secular */ +/* > equation problem is reduced by one. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of non-deflated eigenvalues, and the order of the */ +/* > related secular equation. 0 <= K <=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > The location of the last eigenvalue in the leading sub-matrix. */ +/* > f2cmin(1,N) <= N1 <= N/2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, D contains the eigenvalues of the two submatrices to */ +/* > be combined. */ +/* > On exit, D contains the trailing (N-K) updated eigenvalues */ +/* > (those which were deflated) sorted into increasing order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ, N) */ +/* > On entry, Q contains the eigenvectors of two submatrices in */ +/* > the two square blocks with corners at (1,1), (N1,N1) */ +/* > and (N1+1, N1+1), (N,N). */ +/* > On exit, Q contains the trailing (N-K) updated eigenvectors */ +/* > (those which were deflated) in its last N-K columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] INDXQ */ +/* > \verbatim */ +/* > INDXQ is INTEGER array, dimension (N) */ +/* > The permutation which separately sorts the two sub-problems */ +/* > in D into ascending order. Note that elements in the second */ +/* > half of this permutation must first have N1 added to their */ +/* > values. Destroyed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > On entry, the off-diagonal element associated with the rank-1 */ +/* > cut which originally split the two submatrices which are now */ +/* > being recombined. */ +/* > On exit, RHO has been modified to the value required by */ +/* > SLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (N) */ +/* > On entry, Z contains the updating vector (the last */ +/* > row of the first sub-eigenvector matrix and the first row of */ +/* > the second sub-eigenvector matrix). */ +/* > On exit, the contents of Z have been destroyed by the updating */ +/* > process. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DLAMDA */ +/* > \verbatim */ +/* > DLAMDA is REAL array, dimension (N) */ +/* > A copy of the first K eigenvalues which will be used by */ +/* > SLAED3 to form the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The first k values of the final deflation-altered z-vector */ +/* > which will be passed to SLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q2 */ +/* > \verbatim */ +/* > Q2 is REAL array, dimension (N1**2+(N-N1)**2) */ +/* > A copy of the first K eigenvectors which will be used by */ +/* > SLAED3 in a matrix multiply (SGEMM) to solve for the new */ +/* > eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDX */ +/* > \verbatim */ +/* > INDX is INTEGER array, dimension (N) */ +/* > The permutation used to sort the contents of DLAMDA into */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDXC */ +/* > \verbatim */ +/* > INDXC is INTEGER array, dimension (N) */ +/* > The permutation used to arrange the columns of the deflated */ +/* > Q matrix into three groups: the first group contains non-zero */ +/* > elements only at and above N1, the second contains */ +/* > non-zero elements only below N1, and the third is dense. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDXP */ +/* > \verbatim */ +/* > INDXP is INTEGER array, dimension (N) */ +/* > The permutation used to place deflated values of D at the end */ +/* > of the array. INDXP(1:K) points to the nondeflated D-values */ +/* > and INDXP(K+1:N) points to the deflated eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLTYP */ +/* > \verbatim */ +/* > COLTYP is INTEGER array, dimension (N) */ +/* > During execution, a label which will indicate which of the */ +/* > following types a column in the Q2 matrix is: */ +/* > 1 : non-zero in the upper half only; */ +/* > 2 : dense; */ +/* > 3 : non-zero in the lower half only; */ +/* > 4 : deflated. */ +/* > On exit, COLTYP(i) is the number of columns of type i, */ +/* > for i=1 to 4 only. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA \n */ +/* > Modified by Francoise Tisseur, University of Tennessee */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__, + real *q, integer *ldq, integer *indxq, real *rho, real *z__, real * + dlamda, real *w, real *q2, integer *indx, integer *indxc, integer * + indxp, integer *coltyp, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + integer imax, jmax, ctot[4]; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + real c__; + integer i__, j; + real s, t; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer k2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer n2; + extern real slapy2_(real *, real *); + integer ct, nj, pj, js; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer + *, integer *, integer *), slacpy_(char *, integer *, integer *, + real *, integer *, real *, integer *); + integer iq1, iq2, n1p1; + real eps, tau, tol; + integer psm[4]; + + +/* -- 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__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --indxq; + --z__; + --dlamda; + --w; + --q2; + --indx; + --indxc; + --indxp; + --coltyp; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -2; + } else if (*ldq < f2cmax(1,*n)) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MIN */ + i__1 = 1, i__2 = *n / 2; + if (f2cmin(i__1,i__2) > *n1 || *n / 2 < *n1) { + *info = -3; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + n2 = *n - *n1; + n1p1 = *n1 + 1; + + if (*rho < 0.f) { + sscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + +/* Normalize z so that norm(z) = 1. Since z is the concatenation of */ +/* two normalized vectors, norm2(z) = sqrt(2). */ + + t = 1.f / sqrt(2.f); + sscal_(n, &t, &z__[1], &c__1); + +/* RHO = ABS( norm(z)**2 * RHO ) */ + + *rho = (r__1 = *rho * 2.f, abs(r__1)); + +/* Sort the eigenvalues into increasing order */ + + i__1 = *n; + for (i__ = n1p1; i__ <= i__1; ++i__) { + indxq[i__] += *n1; +/* L10: */ + } + +/* re-integrate the deflated parts from the last pass */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; +/* L20: */ + } + slamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indx[i__] = indxq[indxc[i__]]; +/* L30: */ + } + +/* Calculate the allowable deflation tolerance */ + + imax = isamax_(n, &z__[1], &c__1); + jmax = isamax_(n, &d__[1], &c__1); + eps = slamch_("Epsilon"); +/* Computing MAX */ + r__3 = (r__1 = d__[jmax], abs(r__1)), r__4 = (r__2 = z__[imax], abs(r__2)) + ; + tol = eps * 8.f * f2cmax(r__3,r__4); + +/* If the rank-1 modifier is small enough, no more needs to be done */ +/* except to reorganize Q so that its columns correspond with the */ +/* elements in D. */ + + if (*rho * (r__1 = z__[imax], abs(r__1)) <= tol) { + *k = 0; + iq2 = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = indx[j]; + scopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + dlamda[j] = d__[i__]; + iq2 += *n; +/* L40: */ + } + slacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq); + scopy_(n, &dlamda[1], &c__1, &d__[1], &c__1); + goto L190; + } + +/* If there are multiple eigenvalues then the problem deflates. Here */ +/* the number of equal eigenvalues are found. As each equal */ +/* eigenvalue is found, an elementary reflector is computed to rotate */ +/* the corresponding eigensubspace so that the corresponding */ +/* components of Z are zero in this new basis. */ + + i__1 = *n1; + for (i__ = 1; i__ <= i__1; ++i__) { + coltyp[i__] = 1; +/* L50: */ + } + i__1 = *n; + for (i__ = n1p1; i__ <= i__1; ++i__) { + coltyp[i__] = 3; +/* L60: */ + } + + + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + nj = indx[j]; + if (*rho * (r__1 = z__[nj], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; + if (j == *n) { + goto L100; + } + } else { + pj = nj; + goto L80; + } +/* L70: */ + } +L80: + ++j; + nj = indx[j]; + if (j > *n) { + goto L100; + } + if (*rho * (r__1 = z__[nj], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; + } else { + +/* Check if eigenvalues are close enough to allow deflation. */ + + s = z__[pj]; + c__ = z__[nj]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = slapy2_(&c__, &s); + t = d__[nj] - d__[pj]; + c__ /= tau; + s = -s / tau; + if ((r__1 = t * c__ * s, abs(r__1)) <= tol) { + +/* Deflation is possible. */ + + z__[nj] = tau; + z__[pj] = 0.f; + if (coltyp[nj] != coltyp[pj]) { + coltyp[nj] = 2; + } + coltyp[pj] = 4; + srot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & + c__, &s); +/* Computing 2nd power */ + r__1 = c__; +/* Computing 2nd power */ + r__2 = s; + t = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2); +/* Computing 2nd power */ + r__1 = s; +/* Computing 2nd power */ + r__2 = c__; + d__[nj] = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2); + d__[pj] = t; + --k2; + i__ = 1; +L90: + if (k2 + i__ <= *n) { + if (d__[pj] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = pj; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = pj; + } + } else { + indxp[k2 + i__ - 1] = pj; + } + pj = nj; + } else { + ++(*k); + dlamda[*k] = d__[pj]; + w[*k] = z__[pj]; + indxp[*k] = pj; + pj = nj; + } + } + goto L80; +L100: + +/* Record the last eigenvalue. */ + + ++(*k); + dlamda[*k] = d__[pj]; + w[*k] = z__[pj]; + indxp[*k] = pj; + +/* Count up the total number of the various types of columns, then */ +/* form a permutation which positions the four column types into */ +/* four uniform groups (although one or more of these groups may be */ +/* empty). */ + + for (j = 1; j <= 4; ++j) { + ctot[j - 1] = 0; +/* L110: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ct = coltyp[j]; + ++ctot[ct - 1]; +/* L120: */ + } + +/* PSM(*) = Position in SubMatrix (of types 1 through 4) */ + + psm[0] = 1; + psm[1] = ctot[0] + 1; + psm[2] = psm[1] + ctot[1]; + psm[3] = psm[2] + ctot[2]; + *k = *n - ctot[3]; + +/* Fill out the INDXC array so that the permutation which it induces */ +/* will place all type-1 columns first, all type-2 columns next, */ +/* then all type-3's, and finally all type-4's. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + js = indxp[j]; + ct = coltyp[js]; + indx[psm[ct - 1]] = js; + indxc[psm[ct - 1]] = j; + ++psm[ct - 1]; +/* L130: */ + } + +/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */ +/* and Q2 respectively. The eigenvalues/vectors which were not */ +/* deflated go into the first K slots of DLAMDA and Q2 respectively, */ +/* while those which were deflated go into the last N - K slots. */ + + i__ = 1; + iq1 = 1; + iq2 = (ctot[0] + ctot[1]) * *n1 + 1; + i__1 = ctot[0]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; +/* L140: */ + } + + i__1 = ctot[1]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; + iq2 += n2; +/* L150: */ + } + + i__1 = ctot[2]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq2 += n2; +/* L160: */ + } + + iq1 = iq2; + i__1 = ctot[3]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + scopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + iq2 += *n; + z__[i__] = d__[js]; + ++i__; +/* L170: */ + } + +/* The deflated eigenvalues and their corresponding vectors go back */ +/* into the last N - K slots of D and Q respectively. */ + + if (*k < *n) { + slacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq); + i__1 = *n - *k; + scopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); + } + +/* Copy CTOT into COLTYP for referencing in SLAED3. */ + + for (j = 1; j <= 4; ++j) { + coltyp[j] = ctot[j - 1]; +/* L180: */ + } + +L190: + return 0; + +/* End of SLAED2 */ + +} /* slaed2_ */ + diff --git a/lapack-netlib/SRC/slaed3.c b/lapack-netlib/SRC/slaed3.c new file mode 100644 index 000000000..1b4a6379e --- /dev/null +++ b/lapack-netlib/SRC/slaed3.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 \b SLAED3 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Us +ed when the original matrix is tridiagonal. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, */ +/* CTOT, W, S, INFO ) */ + +/* INTEGER INFO, K, LDQ, N, N1 */ +/* REAL RHO */ +/* INTEGER CTOT( * ), INDX( * ) */ +/* REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), */ +/* $ S( * ), W( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED3 finds the roots of the secular equation, as defined by the */ +/* > values in D, W, and RHO, between 1 and K. It makes the */ +/* > appropriate calls to SLAED4 and then updates the eigenvectors by */ +/* > multiplying the matrix of eigenvectors of the pair of eigensystems */ +/* > being combined by the matrix of eigenvectors of the K-by-K system */ +/* > which is solved here. */ +/* > */ +/* > 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. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of terms in the rational function to be solved by */ +/* > SLAED4. K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows and columns in the Q matrix. */ +/* > N >= K (deflation may result in N>K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > The location of the last eigenvalue in the leading submatrix. */ +/* > f2cmin(1,N) <= N1 <= N/2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > D(I) contains the updated eigenvalues for */ +/* > 1 <= I <= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > Initially the first K columns are used as workspace. */ +/* > On output the columns 1 to K contain */ +/* > the updated eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The value of the parameter in the rank one update equation. */ +/* > RHO >= 0 required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DLAMDA */ +/* > \verbatim */ +/* > DLAMDA is REAL array, dimension (K) */ +/* > The first K elements of this array contain the old roots */ +/* > of the deflated updating problem. These are the poles */ +/* > of the secular equation. May be changed on output by */ +/* > having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */ +/* > Cray-2, or Cray C-90, as described above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q2 */ +/* > \verbatim */ +/* > Q2 is REAL array, dimension (LDQ2*N) */ +/* > The first K columns of this matrix contain the non-deflated */ +/* > eigenvectors for the split problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INDX */ +/* > \verbatim */ +/* > INDX is INTEGER array, dimension (N) */ +/* > The permutation used to arrange the columns of the deflated */ +/* > Q matrix into three groups (see SLAED2). */ +/* > The rows of the eigenvectors found by SLAED4 must be likewise */ +/* > permuted before the matrix multiply can take place. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CTOT */ +/* > \verbatim */ +/* > CTOT is INTEGER array, dimension (4) */ +/* > A count of the total number of the various types of columns */ +/* > in Q, as described in INDX. The fourth column type is any */ +/* > column which has been deflated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (K) */ +/* > The first K elements of this array contain the components */ +/* > of the deflation-adjusted updating vector. Destroyed on */ +/* > output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N1 + 1)*K */ +/* > Will contain the eigenvectors of the repaired matrix which */ +/* > will be multiplied by the previously accumulated eigenvectors */ +/* > to update the system. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, an eigenvalue did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA \n */ +/* > Modified by Francoise Tisseur, University of Tennessee */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__, + real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer * + indx, integer *ctot, real *w, real *s, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + real r__1; + + /* Local variables */ + real temp; + extern real snrm2_(integer *, real *, integer *); + integer i__, j; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *), scopy_(integer *, real *, + integer *, real *, integer *); + integer n2; + extern /* Subroutine */ int slaed4_(integer *, integer *, real *, real *, + real *, real *, real *, integer *); + extern real slamc3_(real *, real *); + integer n12, ii, n23; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacpy_( + char *, integer *, integer *, real *, integer *, real *, integer * + ), slaset_(char *, integer *, integer *, real *, real *, + real *, integer *); + integer iq2; + + +/* -- 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__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --dlamda; + --q2; + --indx; + --ctot; + --w; + --s; + + /* Function Body */ + *info = 0; + + if (*k < 0) { + *info = -1; + } else if (*n < *k) { + *info = -2; + } else if (*ldq < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED3", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*k == 0) { + return 0; + } + +/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DLAMDA(I) if it is 1; this makes the subsequent */ +/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DLAMDA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DLAMDA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; +/* L10: */ + } + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + slaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], + info); + +/* If the zero finder fails, the computation is terminated. */ + + if (*info != 0) { + goto L120; + } +/* L20: */ + } + + if (*k == 1) { + goto L110; + } + if (*k == 2) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + w[1] = q[j * q_dim1 + 1]; + w[2] = q[j * q_dim1 + 2]; + ii = indx[1]; + q[j * q_dim1 + 1] = w[ii]; + ii = indx[2]; + q[j * q_dim1 + 2] = w[ii]; +/* L30: */ + } + goto L110; + } + +/* Compute updated W. */ + + scopy_(k, &w[1], &c__1, &s[1], &c__1); + +/* Initialize W(I) = Q(I,I) */ + + i__1 = *ldq + 1; + scopy_(k, &q[q_offset], &i__1, &w[1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L40: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L50: */ + } +/* L60: */ + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = sqrt(-w[i__]); + w[i__] = r_sign(&r__1, &s[i__]); +/* L70: */ + } + +/* Compute eigenvectors of the modified rank-1 modification. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__] = w[i__] / q[i__ + j * q_dim1]; +/* L80: */ + } + temp = snrm2_(k, &s[1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + ii = indx[i__]; + q[i__ + j * q_dim1] = s[ii] / temp; +/* L90: */ + } +/* L100: */ + } + +/* Compute the updated eigenvectors. */ + +L110: + + n2 = *n - *n1; + n12 = ctot[1] + ctot[2]; + n23 = ctot[2] + ctot[3]; + + slacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23); + iq2 = *n1 * n12 + 1; + if (n23 != 0) { + sgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & + c_b23, &q[*n1 + 1 + q_dim1], ldq); + } else { + slaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq); + } + + slacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12); + if (n12 != 0) { + sgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, + &q[q_offset], ldq); + } else { + slaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq); + } + + +L120: + return 0; + +/* End of SLAED3 */ + +} /* slaed3_ */ + diff --git a/lapack-netlib/SRC/slaed4.c b/lapack-netlib/SRC/slaed4.c new file mode 100644 index 000000000..b9b18521c --- /dev/null +++ b/lapack-netlib/SRC/slaed4.c @@ -0,0 +1,1378 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED4 used by sstedc. Finds a single root of the secular equation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED4 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) */ + +/* INTEGER I, INFO, N */ +/* REAL DLAM, RHO */ +/* REAL D( * ), DELTA( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine computes the I-th updated eigenvalue of a symmetric */ +/* > rank-one modification to a diagonal matrix whose elements are */ +/* > given in the array d, and that */ +/* > */ +/* > D(i) < D(j) for i < j */ +/* > */ +/* > and that RHO > 0. This is arranged by the calling routine, and is */ +/* > no loss in generality. The rank-one modified system is thus */ +/* > */ +/* > diag( D ) + RHO * Z * Z_transpose. */ +/* > */ +/* > where we assume the Euclidean norm of Z is 1. */ +/* > */ +/* > The method consists of approximating the rational functions in the */ +/* > secular equation by simpler interpolating rational functions. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of all arrays. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > The index of the eigenvalue to be computed. 1 <= I <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The original eigenvalues. It is assumed that they are in */ +/* > order, D(I) < D(J) for I < J. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (N) */ +/* > The components of the updating vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DELTA */ +/* > \verbatim */ +/* > DELTA is REAL array, dimension (N) */ +/* > If N > 2, DELTA contains (D(j) - lambda_I) in its j-th */ +/* > component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5 */ +/* > for detail. The vector DELTA contains the information necessary */ +/* > to construct the eigenvectors by SLAED3 and SLAED9. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The scalar in the symmetric updating formula. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DLAM */ +/* > \verbatim */ +/* > DLAM is REAL */ +/* > The computed lambda_I, the I-th updated eigenvalue. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = 1, the updating process failed. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > Logical variable ORGATI (origin-at-i?) is used for distinguishing */ +/* > whether D(i) or D(i+1) is treated as the origin. */ +/* > */ +/* > ORGATI = .true. origin at i */ +/* > ORGATI = .false. origin at i+1 */ +/* > */ +/* > Logical variable SWTCH3 (switch-for-3-poles?) is for noting */ +/* > if we are working with THREE poles! */ +/* > */ +/* > MAXIT is the maximum number of iterations allowed for each */ +/* > eigenvalue. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ren-Cang Li, Computer Science Division, University of California */ +/* > at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaed4_(integer *n, integer *i__, real *d__, real *z__, + real *delta, real *rho, real *dlam, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + real dphi, dpsi; + integer iter; + real temp, prew, temp1, a, b, c__; + integer j; + real w, dltlb, dltub, midpt; + integer niter; + logical swtch; + extern /* Subroutine */ int slaed5_(integer *, real *, real *, real *, + real *, real *), slaed6_(integer *, logical *, real *, real *, + real *, real *, real *, integer *); + logical swtch3; + integer ii; + real dw; + extern real slamch_(char *); + real zz[3]; + logical orgati; + real erretm, rhoinv; + integer ip1; + real del, eta, phi, eps, tau, psi; + integer iim1, iip1; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Since this routine is called in an inner loop, we do no argument */ +/* checking. */ + +/* Quick return for N=1 and 2. */ + + /* Parameter adjustments */ + --delta; + --z__; + --d__; + + /* Function Body */ + *info = 0; + if (*n == 1) { + +/* Presumably, I=1 upon entry */ + + *dlam = d__[1] + *rho * z__[1] * z__[1]; + delta[1] = 1.f; + return 0; + } + if (*n == 2) { + slaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); + return 0; + } + +/* Compute machine epsilon */ + + eps = slamch_("Epsilon"); + rhoinv = 1.f / *rho; + +/* The case I = N */ + + if (*i__ == *n) { + +/* Initialize some basic variables */ + + ii = *n - 1; + niter = 1; + +/* Calculate initial guess */ + + midpt = *rho / 2.f; + +/* If ||Z||_2 is not one, then TEMP should be set to */ +/* RHO * ||Z||_2^2 / TWO */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; +/* L10: */ + } + + psi = 0.f; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; +/* L20: */ + } + + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[* + n]; + + if (w <= 0.f) { + temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho) + + z__[*n] * z__[*n] / *rho; + if (c__ <= temp) { + tau = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n] + ; + b = z__[*n] * z__[*n] * del; + if (a < 0.f) { + tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); + } + } + +/* It can be proved that */ +/* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */ + + dltlb = midpt; + dltub = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * del; + if (a < 0.f) { + tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); + } + +/* It can be proved that */ +/* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */ + + dltlb = 0.f; + dltub = midpt; + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; +/* L30: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L40: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + abs(tau) * ( + dpsi + dphi); + + w = rhoinv + phi + psi; + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } + + if (w <= 0.f) { + dltlb = f2cmax(dltlb,tau); + } else { + dltub = f2cmin(dltub,tau); + } + +/* Calculate the new step */ + + ++niter; + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * ( + dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (c__ < 0.f) { + c__ = abs(c__); + } + if (c__ == 0.f) { +/* ETA = B/A */ +/* ETA = RHO - TAU */ + eta = dltub - tau; + } else if (a >= 0.f) { + eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / ( + c__ * 2.f); + } else { + eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1) + ))); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.f) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.f) { + eta = (dltub - tau) / 2.f; + } else { + eta = (dltlb - tau) / 2.f; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L50: */ + } + + tau += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L60: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + abs(tau) * ( + dpsi + dphi); + + w = rhoinv + phi + psi; + +/* Main loop to update the values of the array DELTA */ + + iter = niter + 1; + + for (niter = iter; niter <= 30; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } + + if (w <= 0.f) { + dltlb = f2cmax(dltlb,tau); + } else { + dltub = f2cmin(dltub,tau); + } + +/* Calculate the new step */ + + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * + (dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (a >= 0.f) { + eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / + (c__ * 2.f); + } else { + eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.f) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.f) { + eta = (dltub - tau) / 2.f; + } else { + eta = (dltlb - tau) / 2.f; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L70: */ + } + + tau += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L80: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + abs(tau) * ( + dpsi + dphi); + + w = rhoinv + phi + psi; +/* L90: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + *dlam = d__[*i__] + tau; + goto L250; + +/* End for the case I = N */ + + } else { + +/* The case for I < N */ + + niter = 1; + ip1 = *i__ + 1; + +/* Calculate initial guess */ + + del = d__[ip1] - d__[*i__]; + midpt = del / 2.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; +/* L100: */ + } + + psi = 0.f; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; +/* L110: */ + } + + phi = 0.f; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / delta[j]; +/* L120: */ + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] / + delta[ip1]; + + if (w > 0.f) { + +/* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 */ + +/* We choose d(i) as origin. */ + + orgati = TRUE_; + a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * del; + if (a > 0.f) { + tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))); + } else { + tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / + (c__ * 2.f); + } + dltlb = 0.f; + dltub = midpt; + } else { + +/* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) */ + +/* We choose d(i+1) as origin. */ + + orgati = FALSE_; + a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * del; + if (a < 0.f) { + tau = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, abs( + r__1)))); + } else { + tau = -(a + sqrt((r__1 = a * a + b * 4.f * c__, abs(r__1)))) / + (c__ * 2.f); + } + dltlb = -midpt; + dltub = 0.f; + } + + if (orgati) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[ip1] - tau; +/* L140: */ + } + } + if (orgati) { + ii = *i__; + } else { + ii = *i__ + 1; + } + iim1 = ii - 1; + iip1 = ii + 1; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L150: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.f; + phi = 0.f; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L160: */ + } + + w = rhoinv + phi + psi; + +/* W is the value of the secular function with */ +/* its ii-th element removed. */ + + swtch3 = FALSE_; + if (orgati) { + if (w < 0.f) { + swtch3 = TRUE_; + } + } else { + if (w > 0.f) { + swtch3 = TRUE_; + } + } + if (ii == 1 || ii == *n) { + swtch3 = FALSE_; + } + + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + abs(temp) * 3.f + + abs(tau) * dw; + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } + + if (w <= 0.f) { + dltlb = f2cmax(dltlb,tau); + } else { + dltub = f2cmin(dltub,tau); + } + +/* Calculate the new step */ + + ++niter; + if (! swtch3) { + if (orgati) { +/* Computing 2nd power */ + r__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (r__1 * + r__1); + } else { +/* Computing 2nd power */ + r__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (r__1 * + r__1); + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * + dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.f) { + if (a == 0.f) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * + (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * + (dpsi + dphi); + } + } + eta = b / a; + } else if (a <= 0.f) { + eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / + (c__ * 2.f); + } else { + eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[ + iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[ + iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info); + if (*info != 0) { + goto L250; + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.f) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.f) { + eta = (dltub - tau) / 2.f; + } else { + eta = (dltlb - tau) / 2.f; + } + } + + prew = w; + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L180: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L190: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.f; + phi = 0.f; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L200: */ + } + + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + abs(temp) * 3.f + + (r__1 = tau + eta, abs(r__1)) * dw; + + swtch = FALSE_; + if (orgati) { + if (-w > abs(prew) / 10.f) { + swtch = TRUE_; + } + } else { + if (w > abs(prew) / 10.f) { + swtch = TRUE_; + } + } + + tau += eta; + +/* Main loop to update the values of the array DELTA */ + + iter = niter + 1; + + for (niter = iter; niter <= 30; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } + + if (w <= 0.f) { + dltlb = f2cmax(dltlb,tau); + } else { + dltub = f2cmin(dltub,tau); + } + +/* Calculate the new step */ + + if (! swtch3) { + if (! swtch) { + if (orgati) { +/* Computing 2nd power */ + r__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * ( + r__1 * r__1); + } else { +/* Computing 2nd power */ + r__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * + (r__1 * r__1); + } + } else { + temp = z__[ii] / delta[ii]; + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi; + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] + * dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.f) { + if (a == 0.f) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * + delta[ip1] * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[ + *i__] * (dpsi + dphi); + } + } else { + a = delta[*i__] * delta[*i__] * dpsi + delta[ip1] + * delta[ip1] * dphi; + } + } + eta = b / a; + } else if (a <= 0.f) { + eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1))) + ) / (c__ * 2.f); + } else { + eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, + abs(r__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi; + zz[0] = delta[iim1] * delta[iim1] * dpsi; + zz[2] = delta[iip1] * delta[iip1] * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] + - d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] + - d__[iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - + temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + } + slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, + info); + if (*info != 0) { + goto L250; + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.f) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.f) { + eta = (dltub - tau) / 2.f; + } else { + eta = (dltlb - tau) / 2.f; + } + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L210: */ + } + + tau += eta; + prew = w; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L220: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.f; + phi = 0.f; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L230: */ + } + + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + abs(temp) * + 3.f + abs(tau) * dw; + if (w * prew > 0.f && abs(w) > abs(prew) / 10.f) { + swtch = ! swtch; + } + +/* L240: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + + } + +L250: + + return 0; + +/* End of SLAED4 */ + +} /* slaed4_ */ + diff --git a/lapack-netlib/SRC/slaed5.c b/lapack-netlib/SRC/slaed5.c new file mode 100644 index 000000000..c49cd62c3 --- /dev/null +++ b/lapack-netlib/SRC/slaed5.c @@ -0,0 +1,573 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED5 used by sstedc. Solves the 2-by-2 secular equation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED5 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM ) */ + +/* INTEGER I */ +/* REAL DLAM, RHO */ +/* REAL D( 2 ), DELTA( 2 ), Z( 2 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine computes the I-th eigenvalue of a symmetric rank-one */ +/* > modification of a 2-by-2 diagonal matrix */ +/* > */ +/* > diag( D ) + RHO * Z * transpose(Z) . */ +/* > */ +/* > The diagonal elements in the array D are assumed to satisfy */ +/* > */ +/* > D(i) < D(j) for i < j . */ +/* > */ +/* > We also assume RHO > 0 and that the Euclidean norm of the vector */ +/* > Z is one. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > The index of the eigenvalue to be computed. I = 1 or I = 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (2) */ +/* > The original eigenvalues. We assume D(1) < D(2). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (2) */ +/* > The components of the updating vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DELTA */ +/* > \verbatim */ +/* > DELTA is REAL array, dimension (2) */ +/* > The vector DELTA contains the information necessary */ +/* > to construct the eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The scalar in the symmetric updating formula. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DLAM */ +/* > \verbatim */ +/* > DLAM is REAL */ +/* > The computed lambda_I, the I-th updated eigenvalue. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ren-Cang Li, Computer Science Division, University of California */ +/* > at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaed5_(integer *i__, real *d__, real *z__, real *delta, + real *rho, real *dlam) +{ + /* System generated locals */ + real r__1; + + /* Local variables */ + real temp, b, c__, w, del, tau; + + +/* -- 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 */ + --delta; + --z__; + --d__; + + /* Function Body */ + del = d__[2] - d__[1]; + if (*i__ == 1) { + w = *rho * 2.f * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.f; + if (w > 0.f) { + b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * del; + +/* B > ZERO, always */ + + tau = c__ * 2.f / (b + sqrt((r__1 = b * b - c__ * 4.f, abs(r__1))) + ); + *dlam = d__[1] + tau; + delta[1] = -z__[1] / tau; + delta[2] = z__[2] / (del - tau); + } else { + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.f) { + tau = c__ * -2.f / (b + sqrt(b * b + c__ * 4.f)); + } else { + tau = (b - sqrt(b * b + c__ * 4.f)) / 2.f; + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + } + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; + } else { + +/* Now I=2 */ + + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.f) { + tau = (b + sqrt(b * b + c__ * 4.f)) / 2.f; + } else { + tau = c__ * 2.f / (-b + sqrt(b * b + c__ * 4.f)); + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; + } + return 0; + +/* End OF SLAED5 */ + +} /* slaed5_ */ + diff --git a/lapack-netlib/SRC/slaed6.c b/lapack-netlib/SRC/slaed6.c new file mode 100644 index 000000000..764f7b8cb --- /dev/null +++ b/lapack-netlib/SRC/slaed6.c @@ -0,0 +1,810 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED6 used by sstedc. Computes one Newton step in solution of the secular equation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED6 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) */ + +/* LOGICAL ORGATI */ +/* INTEGER INFO, KNITER */ +/* REAL FINIT, RHO, TAU */ +/* REAL D( 3 ), Z( 3 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED6 computes the positive or negative root (closest to the origin) */ +/* > of */ +/* > z(1) z(2) z(3) */ +/* > f(x) = rho + --------- + ---------- + --------- */ +/* > d(1)-x d(2)-x d(3)-x */ +/* > */ +/* > It is assumed that */ +/* > */ +/* > if ORGATI = .true. the root is between d(2) and d(3); */ +/* > otherwise it is between d(1) and d(2) */ +/* > */ +/* > This routine will be called by SLAED4 when necessary. In most cases, */ +/* > the root sought is the smallest in magnitude, though it might not be */ +/* > in some extremely rare situations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] KNITER */ +/* > \verbatim */ +/* > KNITER is INTEGER */ +/* > Refer to SLAED4 for its significance. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ORGATI */ +/* > \verbatim */ +/* > ORGATI is LOGICAL */ +/* > If ORGATI is true, the needed root is between d(2) and */ +/* > d(3); otherwise it is between d(1) and d(2). See */ +/* > SLAED4 for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > Refer to the equation f(x) above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (3) */ +/* > D satisfies d(1) < d(2) < d(3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (3) */ +/* > Each of the elements in z must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] FINIT */ +/* > \verbatim */ +/* > FINIT is REAL */ +/* > The value of f at 0. It is more accurate than the one */ +/* > evaluated inside this routine (if someone wants to do */ +/* > so). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > The root of the equation f(x). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = 1, failure to converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 10/02/03: This version has a few statements commented out for thread */ +/* > safety (machine parameters are computed on each entry). SJH. */ +/* > */ +/* > 05/10/06: Modified from a new version of Ren-Cang Li, use */ +/* > Gragg-Thornton-Warner cubic convergent scheme for better stability. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ren-Cang Li, Computer Science Division, University of California */ +/* > at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaed6_(integer *kniter, logical *orgati, real *rho, + real *d__, real *z__, real *finit, real *tau, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + real base; + integer iter; + real temp, temp1, temp2, temp3, temp4, a, b, c__, f; + integer i__; + logical scale; + integer niter; + real small1, small2, fc, df, sminv1, sminv2, dscale[3], sclfac; + extern real slamch_(char *); + real zscale[3], erretm, sclinv, ddf, lbd, eta, ubd, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --z__; + --d__; + + /* Function Body */ + *info = 0; + + if (*orgati) { + lbd = d__[2]; + ubd = d__[3]; + } else { + lbd = d__[1]; + ubd = d__[2]; + } + if (*finit < 0.f) { + lbd = 0.f; + } else { + ubd = 0.f; + } + + niter = 1; + *tau = 0.f; + if (*kniter == 2) { + if (*orgati) { + temp = (d__[3] - d__[2]) / 2.f; + c__ = *rho + z__[1] / (d__[1] - d__[2] - temp); + a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3]; + b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2]; + } else { + temp = (d__[1] - d__[2]) / 2.f; + c__ = *rho + z__[3] / (d__[3] - d__[2] - temp); + a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2]; + b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1]; + } +/* Computing MAX */ + r__1 = abs(a), r__2 = abs(b), r__1 = f2cmax(r__1,r__2), r__2 = abs(c__); + temp = f2cmax(r__1,r__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.f) { + *tau = b / a; + } else if (a <= 0.f) { + *tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / ( + c__ * 2.f); + } else { + *tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))); + } + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.f; + } + if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { + *tau = 0.f; + } else { + temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau + * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / ( + d__[3] * (d__[3] - *tau)); + if (temp <= 0.f) { + lbd = *tau; + } else { + ubd = *tau; + } + if (abs(*finit) <= abs(temp)) { + *tau = 0.f; + } + } + } + +/* get machine parameters for possible scaling to avoid overflow */ + +/* modified by Sven: parameters SMALL1, SMINV1, SMALL2, */ +/* SMINV2, EPS are not SAVEd anymore between one call to the */ +/* others but recomputed at each call */ + + eps = slamch_("Epsilon"); + base = slamch_("Base"); + i__1 = (integer) (log(slamch_("SafMin")) / log(base) / 3.f); + small1 = pow_ri(&base, &i__1); + sminv1 = 1.f / small1; + small2 = small1 * small1; + sminv2 = sminv1 * sminv1; + +/* Determine if scaling of inputs necessary to avoid overflow */ +/* when computing 1/TEMP**3 */ + + if (*orgati) { +/* Computing MIN */ + r__3 = (r__1 = d__[2] - *tau, abs(r__1)), r__4 = (r__2 = d__[3] - * + tau, abs(r__2)); + temp = f2cmin(r__3,r__4); + } else { +/* Computing MIN */ + r__3 = (r__1 = d__[1] - *tau, abs(r__1)), r__4 = (r__2 = d__[2] - * + tau, abs(r__2)); + temp = f2cmin(r__3,r__4); + } + scale = FALSE_; + if (temp <= small1) { + scale = TRUE_; + if (temp <= small2) { + +/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */ + + sclfac = sminv2; + sclinv = small2; + } else { + +/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */ + + sclfac = sminv1; + sclinv = small1; + } + +/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */ + + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__] * sclfac; + zscale[i__ - 1] = z__[i__] * sclfac; +/* L10: */ + } + *tau *= sclfac; + lbd *= sclfac; + ubd *= sclfac; + } else { + +/* Copy D and Z to DSCALE and ZSCALE */ + + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__]; + zscale[i__ - 1] = z__[i__]; +/* L20: */ + } + } + + fc = 0.f; + df = 0.f; + ddf = 0.f; + for (i__ = 1; i__ <= 3; ++i__) { + temp = 1.f / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + fc += temp1 / dscale[i__ - 1]; + df += temp2; + ddf += temp3; +/* L30: */ + } + f = *finit + *tau * fc; + + if (abs(f) <= 0.f) { + goto L60; + } + if (f <= 0.f) { + lbd = *tau; + } else { + ubd = *tau; + } + +/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */ +/* scheme */ + +/* It is not hard to see that */ + +/* 1) Iterations will go up monotonically */ +/* if FINIT < 0; */ + +/* 2) Iterations will go down monotonically */ +/* if FINIT > 0. */ + + iter = niter + 1; + + for (niter = iter; niter <= 40; ++niter) { + + if (*orgati) { + temp1 = dscale[1] - *tau; + temp2 = dscale[2] - *tau; + } else { + temp1 = dscale[0] - *tau; + temp2 = dscale[1] - *tau; + } + a = (temp1 + temp2) * f - temp1 * temp2 * df; + b = temp1 * temp2 * f; + c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf; +/* Computing MAX */ + r__1 = abs(a), r__2 = abs(b), r__1 = f2cmax(r__1,r__2), r__2 = abs(c__); + temp = f2cmax(r__1,r__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.f) { + eta = b / a; + } else if (a <= 0.f) { + eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / ( + c__ * 2.f); + } else { + eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1) + ))); + } + if (f * eta >= 0.f) { + eta = -f / df; + } + + *tau += eta; + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.f; + } + + fc = 0.f; + erretm = 0.f; + df = 0.f; + ddf = 0.f; + for (i__ = 1; i__ <= 3; ++i__) { + if (dscale[i__ - 1] - *tau != 0.f) { + temp = 1.f / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + temp4 = temp1 / dscale[i__ - 1]; + fc += temp4; + erretm += abs(temp4); + df += temp2; + ddf += temp3; + } else { + goto L60; + } +/* L40: */ + } + f = *finit + *tau * fc; + erretm = (abs(*finit) + abs(*tau) * erretm) * 8.f + abs(*tau) * df; + if (abs(f) <= eps * 4.f * erretm || ubd - lbd <= eps * 4.f * abs(*tau) + ) { + goto L60; + } + if (f <= 0.f) { + lbd = *tau; + } else { + ubd = *tau; + } +/* L50: */ + } + *info = 1; +L60: + +/* Undo scaling */ + + if (scale) { + *tau *= sclinv; + } + return 0; + +/* End of SLAED6 */ + +} /* slaed6_ */ + diff --git a/lapack-netlib/SRC/slaed7.c b/lapack-netlib/SRC/slaed7.c new file mode 100644 index 000000000..32aea511f --- /dev/null +++ b/lapack-netlib/SRC/slaed7.c @@ -0,0 +1,830 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification + by a rank-one symmetric matrix. Used when the original matrix is dense. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED7 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, */ +/* LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, */ +/* PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, */ +/* INFO ) */ + +/* INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, */ +/* $ QSIZ, TLVLS */ +/* REAL RHO */ +/* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), */ +/* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) */ +/* REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ), */ +/* $ QSTORE( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED7 computes the updated eigensystem of a diagonal */ +/* > matrix after modification by a rank-one symmetric matrix. This */ +/* > routine is used only for the eigenproblem which requires all */ +/* > eigenvalues and optionally eigenvectors of a dense symmetric matrix */ +/* > that has been reduced to tridiagonal form. SLAED1 handles */ +/* > the case in which all eigenvalues and eigenvectors of a symmetric */ +/* > tridiagonal matrix are desired. */ +/* > */ +/* > T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) */ +/* > */ +/* > where Z = Q**Tu, u is a vector of length N with ones in the */ +/* > CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */ +/* > */ +/* > The eigenvectors of the original matrix are stored in Q, and the */ +/* > eigenvalues are in D. The algorithm consists of three stages: */ +/* > */ +/* > The first stage consists of deflating the size of the problem */ +/* > when there are multiple eigenvalues or if there is a zero in */ +/* > the Z vector. For each such occurrence the dimension of the */ +/* > secular equation problem is reduced by one. This stage is */ +/* > performed by the routine SLAED8. */ +/* > */ +/* > The second stage consists of calculating the updated */ +/* > eigenvalues. This is done by finding the roots of the secular */ +/* > equation via the routine SLAED4 (as called by SLAED9). */ +/* > This routine also calculates the eigenvectors of the current */ +/* > problem. */ +/* > */ +/* > The final stage consists of computing the updated eigenvectors */ +/* > directly using the updated eigenvalues. The eigenvectors for */ +/* > the current problem are multiplied with the eigenvectors from */ +/* > the overall problem. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > = 0: Compute eigenvalues only. */ +/* > = 1: Compute eigenvectors of original dense symmetric matrix */ +/* > also. On entry, Q 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] QSIZ */ +/* > \verbatim */ +/* > QSIZ is INTEGER */ +/* > The dimension of the orthogonal matrix used to reduce */ +/* > the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TLVLS */ +/* > \verbatim */ +/* > TLVLS is INTEGER */ +/* > The total number of merging levels in the overall divide and */ +/* > conquer tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CURLVL */ +/* > \verbatim */ +/* > CURLVL is INTEGER */ +/* > The current level in the overall merge routine, */ +/* > 0 <= CURLVL <= TLVLS. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CURPBM */ +/* > \verbatim */ +/* > CURPBM is INTEGER */ +/* > The current problem in the current level in the overall */ +/* > merge routine (counting from upper left to lower right). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the eigenvalues of the rank-1-perturbed matrix. */ +/* > On exit, the eigenvalues of the repaired matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ, N) */ +/* > On entry, the eigenvectors of the rank-1-perturbed matrix. */ +/* > On exit, the eigenvectors of the repaired tridiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDXQ */ +/* > \verbatim */ +/* > INDXQ is INTEGER array, dimension (N) */ +/* > The permutation which will reintegrate the subproblem just */ +/* > solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) */ +/* > will be in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The subdiagonal element used to create the rank-1 */ +/* > modification. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CUTPNT */ +/* > \verbatim */ +/* > CUTPNT is INTEGER */ +/* > Contains the location of the last eigenvalue in the leading */ +/* > sub-matrix. f2cmin(1,N) <= CUTPNT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] QSTORE */ +/* > \verbatim */ +/* > QSTORE is REAL array, dimension (N**2+1) */ +/* > Stores eigenvectors of submatrices encountered during */ +/* > divide and conquer, packed together. QPTR points to */ +/* > beginning of the submatrices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] QPTR */ +/* > \verbatim */ +/* > QPTR is INTEGER array, dimension (N+2) */ +/* > List of indices pointing to beginning of submatrices stored */ +/* > in QSTORE. The submatrices are numbered starting at the */ +/* > bottom left of the divide and conquer tree, from left to */ +/* > right and bottom to top. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PRMPTR */ +/* > \verbatim */ +/* > PRMPTR is INTEGER array, dimension (N lg N) */ +/* > Contains a list of pointers which indicate where in PERM a */ +/* > level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */ +/* > indicates the size of the permutation and also the size of */ +/* > the full, non-deflated problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension (N lg N) */ +/* > Contains the permutations (from deflation and sorting) to be */ +/* > applied to each eigenblock. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER array, dimension (N lg N) */ +/* > Contains a list of pointers which indicate where in GIVCOL a */ +/* > level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */ +/* > indicates the number of Givens rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension (2, N lg N) */ +/* > Each pair of numbers indicates a pair of columns to take place */ +/* > in a Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, dimension (2, N lg N) */ +/* > Each number indicates the S value to be used in the */ +/* > corresponding Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N+2*QSIZ*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER 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 = 1, an eigenvalue did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slaed7_(integer *icompq, integer *n, integer *qsiz, + integer *tlvls, integer *curlvl, integer *curpbm, real *d__, real *q, + integer *ldq, integer *indxq, real *rho, integer *cutpnt, real * + qstore, integer *qptr, integer *prmptr, integer *perm, integer * + givptr, integer *givcol, real *givnum, real *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + + /* Local variables */ + integer indx, curr, i__, k, indxc; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer indxp, n1, n2; + extern /* Subroutine */ int slaed8_(integer *, integer *, integer *, + integer *, real *, real *, integer *, integer *, real *, integer * + , real *, real *, real *, integer *, real *, integer *, integer *, + integer *, real *, integer *, integer *, integer *), slaed9_( + integer *, integer *, integer *, integer *, real *, real *, + integer *, real *, real *, real *, real *, integer *, integer *), + slaeda_(integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, real *, real *, integer *, real * + , real *, integer *); + integer idlmda, is, iw, iz; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slamrg_( + integer *, integer *, real *, integer *, integer *, integer *); + integer coltyp, iq2, ptr, ldq2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --indxq; + --qstore; + --qptr; + --prmptr; + --perm; + --givptr; + givcol -= 3; + givnum -= 3; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*icompq == 1 && *qsiz < *n) { + *info = -3; + } else if (*ldq < f2cmax(1,*n)) { + *info = -9; + } else if (f2cmin(1,*n) > *cutpnt || *n < *cutpnt) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED7", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* The following values are for bookkeeping purposes only. They are */ +/* integer pointers which indicate the portion of the workspace */ +/* used by a particular array in SLAED8 and SLAED9. */ + + if (*icompq == 1) { + ldq2 = *qsiz; + } else { + ldq2 = *n; + } + + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq2 = iw + *n; + is = iq2 + *n * ldq2; + + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + +/* Form the z-vector which consists of the last row of Q_1 and the */ +/* first row of Q_2. */ + + ptr = pow_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *tlvls - i__; + ptr += pow_ii(&c__2, &i__2); +/* L10: */ + } + curr = ptr + *curpbm; + slaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], & + givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz + + *n], info); + +/* When solving the final problem, we no longer need the stored data, */ +/* so we will overwrite the data from this level onto the previously */ +/* used storage space. */ + + if (*curlvl == *tlvls) { + qptr[curr] = 1; + prmptr[curr] = 1; + givptr[curr] = 1; + } + +/* Sort and Deflate eigenvalues. */ + + slaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, + cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], & + perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1) + + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[ + indx], info); + prmptr[curr + 1] = prmptr[curr] + *n; + givptr[curr + 1] += givptr[curr]; + +/* Solve Secular Equation. */ + + if (k != 0) { + slaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], + &work[iw], &qstore[qptr[curr]], &k, info); + if (*info != 0) { + goto L30; + } + if (*icompq == 1) { + sgemm_("N", "N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[ + qptr[curr]], &k, &c_b11, &q[q_offset], ldq); + } +/* Computing 2nd power */ + i__1 = k; + qptr[curr + 1] = qptr[curr] + i__1 * i__1; + +/* Prepare the INDXQ sorting permutation. */ + + n1 = k; + n2 = *n - k; + slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + qptr[curr + 1] = qptr[curr]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; +/* L20: */ + } + } + +L30: + return 0; + +/* End of SLAED7 */ + +} /* slaed7_ */ + diff --git a/lapack-netlib/SRC/slaed8.c b/lapack-netlib/SRC/slaed8.c new file mode 100644 index 000000000..59b9183ea --- /dev/null +++ b/lapack-netlib/SRC/slaed8.c @@ -0,0 +1,961 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original + matrix is dense. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED8 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, */ +/* CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, */ +/* GIVCOL, GIVNUM, INDXP, INDX, INFO ) */ + +/* INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, */ +/* $ QSIZ */ +/* REAL RHO */ +/* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), */ +/* $ INDXQ( * ), PERM( * ) */ +/* REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ), */ +/* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED8 merges the two sets of eigenvalues together into a single */ +/* > sorted set. Then it tries to deflate the size of the problem. */ +/* > There are two ways in which deflation can occur: when two or more */ +/* > eigenvalues are close together or if there is a tiny element in the */ +/* > Z vector. For each such occurrence the order of the related secular */ +/* > equation problem is reduced by one. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > = 0: Compute eigenvalues only. */ +/* > = 1: Compute eigenvectors of original dense symmetric matrix */ +/* > also. On entry, Q contains the orthogonal matrix used */ +/* > to reduce the original matrix to tridiagonal form. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of non-deflated eigenvalues, and the order of the */ +/* > related secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QSIZ */ +/* > \verbatim */ +/* > QSIZ is INTEGER */ +/* > The dimension of the orthogonal matrix used to reduce */ +/* > the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the eigenvalues of the two submatrices to be */ +/* > combined. On exit, the trailing (N-K) updated eigenvalues */ +/* > (those which were deflated) sorted into increasing order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > If ICOMPQ = 0, Q is not referenced. Otherwise, */ +/* > on entry, Q contains the eigenvectors of the partially solved */ +/* > system which has been previously updated in matrix */ +/* > multiplies with other partially solved eigensystems. */ +/* > On exit, Q contains the trailing (N-K) updated eigenvectors */ +/* > (those which were deflated) in its last N-K columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INDXQ */ +/* > \verbatim */ +/* > INDXQ is INTEGER array, dimension (N) */ +/* > The permutation which separately sorts the two sub-problems */ +/* > in D into ascending order. Note that elements in the second */ +/* > half of this permutation must first have CUTPNT added to */ +/* > their values in order to be accurate. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > On entry, the off-diagonal element associated with the rank-1 */ +/* > cut which originally split the two submatrices which are now */ +/* > being recombined. */ +/* > On exit, RHO has been modified to the value required by */ +/* > SLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CUTPNT */ +/* > \verbatim */ +/* > CUTPNT is INTEGER */ +/* > The location of the last eigenvalue in the leading */ +/* > sub-matrix. f2cmin(1,N) <= CUTPNT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (N) */ +/* > On entry, Z contains the updating vector (the last row of */ +/* > the first sub-eigenvector matrix and the first row of the */ +/* > second sub-eigenvector matrix). */ +/* > On exit, the contents of Z are destroyed by the updating */ +/* > process. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DLAMDA */ +/* > \verbatim */ +/* > DLAMDA is REAL array, dimension (N) */ +/* > A copy of the first K eigenvalues which will be used by */ +/* > SLAED3 to form the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q2 */ +/* > \verbatim */ +/* > Q2 is REAL array, dimension (LDQ2,N) */ +/* > If ICOMPQ = 0, Q2 is not referenced. Otherwise, */ +/* > a copy of the first K eigenvectors which will be used by */ +/* > SLAED7 in a matrix multiply (SGEMM) to update the new */ +/* > eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ2 */ +/* > \verbatim */ +/* > LDQ2 is INTEGER */ +/* > The leading dimension of the array Q2. LDQ2 >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The first k values of the final deflation-altered z-vector and */ +/* > will be passed to SLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension (N) */ +/* > The permutations (from deflation and sorting) to be applied */ +/* > to each eigenblock. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER */ +/* > The number of Givens rotations which took place in this */ +/* > subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension (2, N) */ +/* > Each pair of numbers indicates a pair of columns to take place */ +/* > in a Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, dimension (2, N) */ +/* > Each number indicates the S value to be used in the */ +/* > corresponding Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDXP */ +/* > \verbatim */ +/* > INDXP is INTEGER array, dimension (N) */ +/* > The permutation used to place deflated values of D at the end */ +/* > of the array. INDXP(1:K) points to the nondeflated D-values */ +/* > and INDXP(K+1:N) points to the deflated eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDX */ +/* > \verbatim */ +/* > INDX is INTEGER array, dimension (N) */ +/* > The permutation used to sort the contents of D into ascending */ +/* > order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slaed8_(integer *icompq, integer *k, integer *n, integer + *qsiz, real *d__, real *q, integer *ldq, integer *indxq, real *rho, + integer *cutpnt, real *z__, real *dlamda, real *q2, integer *ldq2, + real *w, integer *perm, integer *givptr, integer *givcol, real * + givnum, integer *indxp, integer *indx, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + real r__1; + + /* Local variables */ + integer jlam, imax, jmax; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + real c__; + integer i__, j; + real s, t; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer k2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer n1, n2; + extern real slapy2_(real *, real *); + integer jp; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer + *, integer *, integer *), slacpy_(char *, integer *, integer *, + real *, integer *, real *, integer *); + integer n1p1; + real eps, tau, tol; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --indxq; + --z__; + --dlamda; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1 * 1; + q2 -= q2_offset; + --w; + --perm; + givcol -= 3; + givnum -= 3; + --indxp; + --indx; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*n < 0) { + *info = -3; + } else if (*icompq == 1 && *qsiz < *n) { + *info = -4; + } else if (*ldq < f2cmax(1,*n)) { + *info = -7; + } else if (*cutpnt < f2cmin(1,*n) || *cutpnt > *n) { + *info = -10; + } else if (*ldq2 < f2cmax(1,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED8", &i__1, (ftnlen)6); + return 0; + } + +/* Need to initialize GIVPTR to O here in case of quick exit */ +/* to prevent an unspecified code behavior (usually sigfault) */ +/* when IWORK array on entry to *stedc is not zeroed */ +/* (or at least some IWORK entries which used in *laed7 for GIVPTR). */ + + *givptr = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + n1 = *cutpnt; + n2 = *n - n1; + n1p1 = n1 + 1; + + if (*rho < 0.f) { + sscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + +/* Normalize z so that norm(z) = 1 */ + + t = 1.f / sqrt(2.f); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; +/* L10: */ + } + sscal_(n, &t, &z__[1], &c__1); + *rho = (r__1 = *rho * 2.f, abs(r__1)); + +/* Sort the eigenvalues into increasing order */ + + i__1 = *n; + for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { + indxq[i__] += *cutpnt; +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; +/* L30: */ + } + i__ = 1; + j = *cutpnt + 1; + slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = dlamda[indx[i__]]; + z__[i__] = w[indx[i__]]; +/* L40: */ + } + +/* Calculate the allowable deflation tolerance */ + + imax = isamax_(n, &z__[1], &c__1); + jmax = isamax_(n, &d__[1], &c__1); + eps = slamch_("Epsilon"); + tol = eps * 8.f * (r__1 = d__[jmax], abs(r__1)); + +/* If the rank-1 modifier is small enough, no more needs to be done */ +/* except to reorganize Q so that its columns correspond with the */ +/* elements in D. */ + + if (*rho * (r__1 = z__[imax], abs(r__1)) <= tol) { + *k = 0; + if (*icompq == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; +/* L50: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + scopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + + 1], &c__1); +/* L60: */ + } + slacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq); + } + return 0; + } + +/* If there are multiple eigenvalues then the problem deflates. Here */ +/* the number of equal eigenvalues are found. As each equal */ +/* eigenvalue is found, an elementary reflector is computed to rotate */ +/* the corresponding eigensubspace so that the corresponding */ +/* components of Z are zero in this new basis. */ + + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*rho * (r__1 = z__[j], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + indxp[k2] = j; + if (j == *n) { + goto L110; + } + } else { + jlam = j; + goto L80; + } +/* L70: */ + } +L80: + ++j; + if (j > *n) { + goto L100; + } + if (*rho * (r__1 = z__[j], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + indxp[k2] = j; + } else { + +/* Check if eigenvalues are close enough to allow deflation. */ + + s = z__[jlam]; + c__ = z__[j]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = slapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((r__1 = t * c__ * s, abs(r__1)) <= tol) { + +/* Deflation is possible. */ + + z__[j] = tau; + z__[jlam] = 0.f; + +/* Record the appropriate Givens rotation */ + + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + if (*icompq == 1) { + srot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ + indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s); + } + t = d__[jlam] * c__ * c__ + d__[j] * s * s; + d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; + d__[jlam] = t; + --k2; + i__ = 1; +L90: + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } + } + goto L80; +L100: + +/* Record the last eigenvalue. */ + + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + +L110: + +/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */ +/* and Q2 respectively. The eigenvalues/vectors which were not */ +/* deflated go into the first K slots of DLAMDA and Q2 respectively, */ +/* while those which were deflated go into the last N - K slots. */ + + if (*icompq == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; +/* L120: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + scopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] + , &c__1); +/* L130: */ + } + } + +/* The deflated eigenvalues and their corresponding vectors go back */ +/* into the last N - K slots of D and Q respectively. */ + + if (*k < *n) { + if (*icompq == 0) { + i__1 = *n - *k; + scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + } else { + i__1 = *n - *k; + scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + slacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* + k + 1) * q_dim1 + 1], ldq); + } + } + + return 0; + +/* End of SLAED8 */ + +} /* slaed8_ */ + diff --git a/lapack-netlib/SRC/slaed9.c b/lapack-netlib/SRC/slaed9.c new file mode 100644 index 000000000..29106e1f6 --- /dev/null +++ b/lapack-netlib/SRC/slaed9.c @@ -0,0 +1,719 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAED9 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Us +ed when the original matrix is dense. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAED9 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, */ +/* S, LDS, INFO ) */ + +/* INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N */ +/* REAL RHO */ +/* REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), */ +/* $ W( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAED9 finds the roots of the secular equation, as defined by the */ +/* > values in D, Z, and RHO, between KSTART and KSTOP. It makes the */ +/* > appropriate calls to SLAED4 and then stores the new matrix of */ +/* > eigenvectors for use in calculating the next level of Z vectors. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of terms in the rational function to be solved by */ +/* > SLAED4. K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KSTART */ +/* > \verbatim */ +/* > KSTART is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KSTOP */ +/* > \verbatim */ +/* > KSTOP is INTEGER */ +/* > The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP */ +/* > are to be computed. 1 <= KSTART <= KSTOP <= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows and columns in the Q matrix. */ +/* > N >= K (delation may result in N > K). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > D(I) contains the updated eigenvalues */ +/* > for KSTART <= I <= KSTOP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The value of the parameter in the rank one update equation. */ +/* > RHO >= 0 required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DLAMDA */ +/* > \verbatim */ +/* > DLAMDA is REAL array, dimension (K) */ +/* > The first K elements of this array contain the old roots */ +/* > of the deflated updating problem. These are the poles */ +/* > of the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (K) */ +/* > The first K elements of this array contain the components */ +/* > of the deflation-adjusted updating vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (LDS, K) */ +/* > Will contain the eigenvectors of the repaired matrix which */ +/* > will be stored for subsequent Z vector calculation and */ +/* > multiplied by the previously accumulated eigenvectors */ +/* > to update the system. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDS */ +/* > \verbatim */ +/* > LDS is INTEGER */ +/* > The leading dimension of S. LDS >= f2cmax( 1, K ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, an eigenvalue did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slaed9_(integer *k, integer *kstart, integer *kstop, + integer *n, real *d__, real *q, integer *ldq, real *rho, real *dlamda, + real *w, real *s, integer *lds, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; + real r__1; + + /* Local variables */ + real temp; + extern real snrm2_(integer *, real *, integer *); + integer i__, j; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), slaed4_(integer *, integer *, real *, real *, real *, + real *, real *, integer *); + extern real slamc3_(real *, real *); + 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 */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --dlamda; + --w; + s_dim1 = *lds; + s_offset = 1 + s_dim1 * 1; + s -= s_offset; + + /* Function Body */ + *info = 0; + + if (*k < 0) { + *info = -1; + } else if (*kstart < 1 || *kstart > f2cmax(1,*k)) { + *info = -2; + } else if (f2cmax(1,*kstop) < *kstart || *kstop > f2cmax(1,*k)) { + *info = -3; + } else if (*n < *k) { + *info = -4; + } else if (*ldq < f2cmax(1,*k)) { + *info = -7; + } else if (*lds < f2cmax(1,*k)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED9", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*k == 0) { + return 0; + } + +/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DLAMDA(I) if it is 1; this makes the subsequent */ +/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DLAMDA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DLAMDA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; +/* L10: */ + } + + i__1 = *kstop; + for (j = *kstart; j <= i__1; ++j) { + slaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], + info); + +/* If the zero finder fails, the computation is terminated. */ + + if (*info != 0) { + goto L120; + } +/* L20: */ + } + + if (*k == 1 || *k == 2) { + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *k; + for (j = 1; j <= i__2; ++j) { + s[j + i__ * s_dim1] = q[j + i__ * q_dim1]; +/* L30: */ + } +/* L40: */ + } + goto L120; + } + +/* Compute updated W. */ + + scopy_(k, &w[1], &c__1, &s[s_offset], &c__1); + +/* Initialize W(I) = Q(I,I) */ + + i__1 = *ldq + 1; + scopy_(k, &q[q_offset], &i__1, &w[1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L50: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L60: */ + } +/* L70: */ + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = sqrt(-w[i__]); + w[i__] = r_sign(&r__1, &s[i__ + s_dim1]); +/* L80: */ + } + +/* Compute eigenvectors of the modified rank-1 modification. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1]; +/* L90: */ + } + temp = snrm2_(k, &q[j * q_dim1 + 1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp; +/* L100: */ + } +/* L110: */ + } + +L120: + return 0; + +/* End of SLAED9 */ + +} /* slaed9_ */ + diff --git a/lapack-netlib/SRC/slaeda.c b/lapack-netlib/SRC/slaeda.c new file mode 100644 index 000000000..8e1637e00 --- /dev/null +++ b/lapack-netlib/SRC/slaeda.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 SLAEDA used by sstedc. Computes the Z vector determining the rank-one modification of the diago +nal matrix. Used when the original matrix is dense. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAEDA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, */ +/* GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) */ + +/* INTEGER CURLVL, CURPBM, INFO, N, TLVLS */ +/* INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), */ +/* $ PRMPTR( * ), QPTR( * ) */ +/* REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAEDA computes the Z vector corresponding to the merge step in the */ +/* > CURLVLth step of the merge process with TLVLS steps for the CURPBMth */ +/* > problem. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TLVLS */ +/* > \verbatim */ +/* > TLVLS is INTEGER */ +/* > The total number of merging levels in the overall divide and */ +/* > conquer tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CURLVL */ +/* > \verbatim */ +/* > CURLVL is INTEGER */ +/* > The current level in the overall merge routine, */ +/* > 0 <= curlvl <= tlvls. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CURPBM */ +/* > \verbatim */ +/* > CURPBM is INTEGER */ +/* > The current problem in the current level in the overall */ +/* > merge routine (counting from upper left to lower right). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PRMPTR */ +/* > \verbatim */ +/* > PRMPTR is INTEGER array, dimension (N lg N) */ +/* > Contains a list of pointers which indicate where in PERM a */ +/* > level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */ +/* > indicates the size of the permutation and incidentally the */ +/* > size of the full, non-deflated problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension (N lg N) */ +/* > Contains the permutations (from deflation and sorting) to be */ +/* > applied to each eigenblock. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER array, dimension (N lg N) */ +/* > Contains a list of pointers which indicate where in GIVCOL a */ +/* > level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */ +/* > indicates the number of Givens rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension (2, N lg N) */ +/* > Each pair of numbers indicates a pair of columns to take place */ +/* > in a Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, dimension (2, N lg N) */ +/* > Each number indicates the S value to be used in the */ +/* > corresponding Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (N**2) */ +/* > Contains the square eigenblocks from previous levels, the */ +/* > starting positions for blocks are given by QPTR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QPTR */ +/* > \verbatim */ +/* > QPTR is INTEGER array, dimension (N+2) */ +/* > Contains a list of pointers which indicate where in Q an */ +/* > eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates */ +/* > the size of the block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (N) */ +/* > On output this vector contains the updating vector (the last */ +/* > row of the first sub-eigenvector matrix and the first row of */ +/* > the second sub-eigenvector matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ZTEMP */ +/* > \verbatim */ +/* > ZTEMP is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slaeda_(integer *n, integer *tlvls, integer *curlvl, + integer *curpbm, integer *prmptr, integer *perm, integer *givptr, + integer *givcol, real *givnum, real *q, integer *qptr, real *z__, + real *ztemp, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer curr; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer bsiz1, bsiz2, psiz1, psiz2, i__, k, zptr1; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *), + xerbla_(char *, integer *, ftnlen); + integer mid, ptr; + + +/* -- 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 */ + --ztemp; + --z__; + --qptr; + --q; + givnum -= 3; + givcol -= 3; + --givptr; + --perm; + --prmptr; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -1; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAEDA", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine location of first number in second half. */ + + mid = *n / 2 + 1; + +/* Gather last/first rows of appropriate eigenblocks into center of Z */ + + ptr = 1; + +/* Determine location of lowest level subproblem in the full storage */ +/* scheme */ + + i__1 = *curlvl - 1; + curr = ptr + *curpbm * pow_ii(&c__2, curlvl) + pow_ii(&c__2, &i__1) - 1; + +/* Determine size of these matrices. We add HALF to the value of */ +/* the SQRT in case the machine underestimates one of these square */ +/* roots. */ + + bsiz1 = (integer) (sqrt((real) (qptr[curr + 1] - qptr[curr])) + .5f); + bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) + .5f); + i__1 = mid - bsiz1 - 1; + for (k = 1; k <= i__1; ++k) { + z__[k] = 0.f; +/* L10: */ + } + scopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], & + c__1); + scopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); + i__1 = *n; + for (k = mid + bsiz2; k <= i__1; ++k) { + z__[k] = 0.f; +/* L20: */ + } + +/* Loop through remaining levels 1 -> CURLVL applying the Givens */ +/* rotations and permutation and then multiplying the center matrices */ +/* against the current Z. */ + + ptr = pow_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = *curlvl - k; + i__3 = *curlvl - k - 1; + curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) - + 1; + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + zptr1 = mid - psiz1; + +/* Apply Givens at CURR and CURR+1 */ + + i__2 = givptr[curr + 1] - 1; + for (i__ = givptr[curr]; i__ <= i__2; ++i__) { + srot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, & + z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[( + i__ << 1) + 1], &givnum[(i__ << 1) + 2]); +/* L30: */ + } + i__2 = givptr[curr + 2] - 1; + for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) { + srot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[ + mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << + 1) + 1], &givnum[(i__ << 1) + 2]); +/* L40: */ + } + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + i__2 = psiz1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1]; +/* L50: */ + } + i__2 = psiz2 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - + 1]; +/* L60: */ + } + +/* Multiply Blocks at CURR and CURR+1 */ + +/* Determine size of these matrices. We add HALF to the value of */ +/* the SQRT in case the machine underestimates one of these */ +/* square roots. */ + + bsiz1 = (integer) (sqrt((real) (qptr[curr + 1] - qptr[curr])) + .5f); + bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) + + .5f); + if (bsiz1 > 0) { + sgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & + ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1); + } + i__2 = psiz1 - bsiz1; + scopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); + if (bsiz2 > 0) { + sgemv_("T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, & + ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1); + } + i__2 = psiz2 - bsiz2; + scopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], & + c__1); + + i__2 = *tlvls - k; + ptr += pow_ii(&c__2, &i__2); +/* L70: */ + } + + return 0; + +/* End of SLAEDA */ + +} /* slaeda_ */ + diff --git a/lapack-netlib/SRC/slaein.c b/lapack-netlib/SRC/slaein.c new file mode 100644 index 000000000..0008352e4 --- /dev/null +++ b/lapack-netlib/SRC/slaein.c @@ -0,0 +1,1134 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse +iteration. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAEIN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, */ +/* LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) */ + +/* LOGICAL NOINIT, RIGHTV */ +/* INTEGER INFO, LDB, LDH, N */ +/* REAL BIGNUM, EPS3, SMLNUM, WI, WR */ +/* REAL B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAEIN uses inverse iteration to find a right or left eigenvector */ +/* > corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg */ +/* > matrix H. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] RIGHTV */ +/* > \verbatim */ +/* > RIGHTV is LOGICAL */ +/* > = .TRUE. : compute right eigenvector; */ +/* > = .FALSE.: compute left eigenvector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NOINIT */ +/* > \verbatim */ +/* > NOINIT is LOGICAL */ +/* > = .TRUE. : no initial vector supplied in (VR,VI). */ +/* > = .FALSE.: initial vector supplied in (VR,VI). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > The upper Hessenberg matrix H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WR */ +/* > \verbatim */ +/* > WR is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WI */ +/* > \verbatim */ +/* > WI is REAL */ +/* > The real and imaginary parts of the eigenvalue of H whose */ +/* > corresponding right or left eigenvector is to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VI */ +/* > \verbatim */ +/* > VI is REAL array, dimension (N) */ +/* > On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */ +/* > a real starting vector for inverse iteration using the real */ +/* > eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */ +/* > must contain the real and imaginary parts of a complex */ +/* > starting vector for inverse iteration using the complex */ +/* > eigenvalue (WR,WI); otherwise VR and VI need not be set. */ +/* > On exit, if WI = 0.0 (real eigenvalue), VR contains the */ +/* > computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), */ +/* > VR and VI contain the real and imaginary parts of the */ +/* > computed complex eigenvector. The eigenvector is normalized */ +/* > so that the component of largest magnitude has magnitude 1; */ +/* > here the magnitude of a complex number (x,y) is taken to be */ +/* > |x| + |y|. */ +/* > VI is not referenced if WI = 0.0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= N+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EPS3 */ +/* > \verbatim */ +/* > EPS3 is REAL */ +/* > A small machine-dependent value which is used to perturb */ +/* > close eigenvalues, and to replace zero pivots. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLNUM */ +/* > \verbatim */ +/* > SMLNUM is REAL */ +/* > A machine-dependent value close to the underflow threshold. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BIGNUM */ +/* > \verbatim */ +/* > BIGNUM is REAL */ +/* > A machine-dependent value close to the overflow threshold. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > = 1: inverse iteration did not converge; VR is set to the */ +/* > last iterate, and so is VI if WI.ne.0.0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaein_(logical *rightv, logical *noinit, integer *n, + real *h__, integer *ldh, real *wr, real *wi, real *vr, real *vi, real + *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum, + integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + integer ierr; + real temp, norm, vmax; + extern real snrm2_(integer *, real *, integer *); + integer i__, j; + real scale, w, x, y; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + char trans[1]; + real vcrit; + extern real sasum_(integer *, real *, integer *); + integer i1, i2, i3; + real rootn, vnorm, w1; + extern real slapy2_(real *, real *); + real ei, ej, absbii, absbjj, xi, xr; + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real * + , real *); + char normin[1]; + real nrmsml; + extern /* Subroutine */ int slatrs_(char *, char *, char *, char *, + integer *, real *, integer *, real *, real *, real *, integer *); + real growto, rec; + integer its; + + +/* -- 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 */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --vr; + --vi; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + +/* GROWTO is the threshold used in the acceptance test for an */ +/* eigenvector. */ + + rootn = sqrt((real) (*n)); + growto = .1f / rootn; +/* Computing MAX */ + r__1 = 1.f, r__2 = *eps3 * rootn; + nrmsml = f2cmax(r__1,r__2) * *smlnum; + +/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */ +/* the imaginary parts of the diagonal elements are not stored). */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = h__[i__ + j * h_dim1]; +/* L10: */ + } + b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr; +/* L20: */ + } + + if (*wi == 0.f) { + +/* Real eigenvalue. */ + + if (*noinit) { + +/* Set initial vector. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + vr[i__] = *eps3; +/* L30: */ + } + } else { + +/* Scale supplied initial vector. */ + + vnorm = snrm2_(n, &vr[1], &c__1); + r__1 = *eps3 * rootn / f2cmax(vnorm,nrmsml); + sscal_(n, &r__1, &vr[1], &c__1); + } + + if (*rightv) { + +/* LU decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + ei = h__[i__ + 1 + i__ * h_dim1]; + if ((r__1 = b[i__ + i__ * b_dim1], abs(r__1)) < abs(ei)) { + +/* Interchange rows and eliminate. */ + + x = b[i__ + i__ * b_dim1] / ei; + b[i__ + i__ * b_dim1] = ei; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x * + temp; + b[i__ + j * b_dim1] = temp; +/* L40: */ + } + } else { + +/* Eliminate without interchange. */ + + if (b[i__ + i__ * b_dim1] == 0.f) { + b[i__ + i__ * b_dim1] = *eps3; + } + x = ei / b[i__ + i__ * b_dim1]; + if (x != 0.f) { + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1] + ; +/* L50: */ + } + } + } +/* L60: */ + } + if (b[*n + *n * b_dim1] == 0.f) { + b[*n + *n * b_dim1] = *eps3; + } + + *(unsigned char *)trans = 'N'; + + } else { + +/* UL decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + + for (j = *n; j >= 2; --j) { + ej = h__[j + (j - 1) * h_dim1]; + if ((r__1 = b[j + j * b_dim1], abs(r__1)) < abs(ej)) { + +/* Interchange columns and eliminate. */ + + x = b[j + j * b_dim1] / ej; + b[j + j * b_dim1] = ej; + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = b[i__ + (j - 1) * b_dim1]; + b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x * + temp; + b[i__ + j * b_dim1] = temp; +/* L70: */ + } + } else { + +/* Eliminate without interchange. */ + + if (b[j + j * b_dim1] == 0.f) { + b[j + j * b_dim1] = *eps3; + } + x = ej / b[j + j * b_dim1]; + if (x != 0.f) { + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j * + b_dim1]; +/* L80: */ + } + } + } +/* L90: */ + } + if (b[b_dim1 + 1] == 0.f) { + b[b_dim1 + 1] = *eps3; + } + + *(unsigned char *)trans = 'T'; + + } + + *(unsigned char *)normin = 'N'; + i__1 = *n; + for (its = 1; its <= i__1; ++its) { + +/* Solve U*x = scale*v for a right eigenvector */ +/* or U**T*x = scale*v for a left eigenvector, */ +/* overwriting x on v. */ + + slatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, & + vr[1], &scale, &work[1], &ierr); + *(unsigned char *)normin = 'Y'; + +/* Test for sufficient growth in the norm of v. */ + + vnorm = sasum_(n, &vr[1], &c__1); + if (vnorm >= growto * scale) { + goto L120; + } + +/* Choose new orthogonal starting vector and try again. */ + + temp = *eps3 / (rootn + 1.f); + vr[1] = *eps3; + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + vr[i__] = temp; +/* L100: */ + } + vr[*n - its + 1] -= *eps3 * rootn; +/* L110: */ + } + +/* Failure to find eigenvector in N iterations. */ + + *info = 1; + +L120: + +/* Normalize eigenvector. */ + + i__ = isamax_(n, &vr[1], &c__1); + r__2 = 1.f / (r__1 = vr[i__], abs(r__1)); + sscal_(n, &r__2, &vr[1], &c__1); + } else { + +/* Complex eigenvalue. */ + + if (*noinit) { + +/* Set initial vector. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + vr[i__] = *eps3; + vi[i__] = 0.f; +/* L130: */ + } + } else { + +/* Scale supplied initial vector. */ + + r__1 = snrm2_(n, &vr[1], &c__1); + r__2 = snrm2_(n, &vi[1], &c__1); + norm = slapy2_(&r__1, &r__2); + rec = *eps3 * rootn / f2cmax(norm,nrmsml); + sscal_(n, &rec, &vr[1], &c__1); + sscal_(n, &rec, &vi[1], &c__1); + } + + if (*rightv) { + +/* LU decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + +/* The imaginary part of the (i,j)-th element of U is stored in */ +/* B(j+1,i). */ + + b[b_dim1 + 2] = -(*wi); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + b[i__ + 1 + b_dim1] = 0.f; +/* L140: */ + } + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + absbii = slapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * + b_dim1]); + ei = h__[i__ + 1 + i__ * h_dim1]; + if (absbii < abs(ei)) { + +/* Interchange rows and eliminate. */ + + xr = b[i__ + i__ * b_dim1] / ei; + xi = b[i__ + 1 + i__ * b_dim1] / ei; + b[i__ + i__ * b_dim1] = ei; + b[i__ + 1 + i__ * b_dim1] = 0.f; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr * + temp; + b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ * + b_dim1] - xi * temp; + b[i__ + j * b_dim1] = temp; + b[j + 1 + i__ * b_dim1] = 0.f; +/* L150: */ + } + b[i__ + 2 + i__ * b_dim1] = -(*wi); + b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi; + b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi; + } else { + +/* Eliminate without interchanging rows. */ + + if (absbii == 0.f) { + b[i__ + i__ * b_dim1] = *eps3; + b[i__ + 1 + i__ * b_dim1] = 0.f; + absbii = *eps3; + } + ei = ei / absbii / absbii; + xr = b[i__ + i__ * b_dim1] * ei; + xi = -b[i__ + 1 + i__ * b_dim1] * ei; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] - + xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ + * b_dim1]; + b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ * + b_dim1] - xi * b[i__ + j * b_dim1]; +/* L160: */ + } + b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi; + } + +/* Compute 1-norm of offdiagonal elements of i-th row. */ + + i__2 = *n - i__; + i__3 = *n - i__; + work[i__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) + + sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1); +/* L170: */ + } + if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f) + { + b[*n + *n * b_dim1] = *eps3; + } + work[*n] = 0.f; + + i1 = *n; + i2 = 1; + i3 = -1; + } else { + +/* UL decomposition with partial pivoting of conjg(B), */ +/* replacing zero pivots by EPS3. */ + +/* The imaginary part of the (i,j)-th element of U is stored in */ +/* B(j+1,i). */ + + b[*n + 1 + *n * b_dim1] = *wi; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + b[*n + 1 + j * b_dim1] = 0.f; +/* L180: */ + } + + for (j = *n; j >= 2; --j) { + ej = h__[j + (j - 1) * h_dim1]; + absbjj = slapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]); + if (absbjj < abs(ej)) { + +/* Interchange columns and eliminate */ + + xr = b[j + j * b_dim1] / ej; + xi = b[j + 1 + j * b_dim1] / ej; + b[j + j * b_dim1] = ej; + b[j + 1 + j * b_dim1] = 0.f; + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = b[i__ + (j - 1) * b_dim1]; + b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr * + temp; + b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * + temp; + b[i__ + j * b_dim1] = temp; + b[j + 1 + i__ * b_dim1] = 0.f; +/* L190: */ + } + b[j + 1 + (j - 1) * b_dim1] = *wi; + b[j - 1 + (j - 1) * b_dim1] += xi * *wi; + b[j + (j - 1) * b_dim1] -= xr * *wi; + } else { + +/* Eliminate without interchange. */ + + if (absbjj == 0.f) { + b[j + j * b_dim1] = *eps3; + b[j + 1 + j * b_dim1] = 0.f; + absbjj = *eps3; + } + ej = ej / absbjj / absbjj; + xr = b[j + j * b_dim1] * ej; + xi = -b[j + 1 + j * b_dim1] * ej; + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1] + - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + + i__ * b_dim1]; + b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - + xi * b[i__ + j * b_dim1]; +/* L200: */ + } + b[j + (j - 1) * b_dim1] += *wi; + } + +/* Compute 1-norm of offdiagonal elements of j-th column. */ + + i__1 = j - 1; + i__2 = j - 1; + work[j] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(& + i__2, &b[j + 1 + b_dim1], ldb); +/* L210: */ + } + if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f) { + b[b_dim1 + 1] = *eps3; + } + work[1] = 0.f; + + i1 = 1; + i2 = *n; + i3 = 1; + } + + i__1 = *n; + for (its = 1; its <= i__1; ++its) { + scale = 1.f; + vmax = 1.f; + vcrit = *bignum; + +/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */ +/* or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector, */ +/* overwriting (xr,xi) on (vr,vi). */ + + i__2 = i2; + i__3 = i3; + for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) + { + + if (work[i__] > vcrit) { + rec = 1.f / vmax; + sscal_(n, &rec, &vr[1], &c__1); + sscal_(n, &rec, &vi[1], &c__1); + scale *= rec; + vmax = 1.f; + vcrit = *bignum; + } + + xr = vr[i__]; + xi = vi[i__]; + if (*rightv) { + i__4 = *n; + for (j = i__ + 1; j <= i__4; ++j) { + xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__ + * b_dim1] * vi[j]; + xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__ + * b_dim1] * vr[j]; +/* L220: */ + } + } else { + i__4 = i__ - 1; + for (j = 1; j <= i__4; ++j) { + xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j + * b_dim1] * vi[j]; + xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j + * b_dim1] * vr[j]; +/* L230: */ + } + } + + w = (r__1 = b[i__ + i__ * b_dim1], abs(r__1)) + (r__2 = b[i__ + + 1 + i__ * b_dim1], abs(r__2)); + if (w > *smlnum) { + if (w < 1.f) { + w1 = abs(xr) + abs(xi); + if (w1 > w * *bignum) { + rec = 1.f / w1; + sscal_(n, &rec, &vr[1], &c__1); + sscal_(n, &rec, &vi[1], &c__1); + xr = vr[i__]; + xi = vi[i__]; + scale *= rec; + vmax *= rec; + } + } + +/* Divide by diagonal element of B. */ + + sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + + i__ * b_dim1], &vr[i__], &vi[i__]); +/* Computing MAX */ + r__3 = (r__1 = vr[i__], abs(r__1)) + (r__2 = vi[i__], abs( + r__2)); + vmax = f2cmax(r__3,vmax); + vcrit = *bignum / vmax; + } else { + i__4 = *n; + for (j = 1; j <= i__4; ++j) { + vr[j] = 0.f; + vi[j] = 0.f; +/* L240: */ + } + vr[i__] = 1.f; + vi[i__] = 1.f; + scale = 0.f; + vmax = 1.f; + vcrit = *bignum; + } +/* L250: */ + } + +/* Test for sufficient growth in the norm of (VR,VI). */ + + vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1); + if (vnorm >= growto * scale) { + goto L280; + } + +/* Choose a new orthogonal starting vector and try again. */ + + y = *eps3 / (rootn + 1.f); + vr[1] = *eps3; + vi[1] = 0.f; + + i__3 = *n; + for (i__ = 2; i__ <= i__3; ++i__) { + vr[i__] = y; + vi[i__] = 0.f; +/* L260: */ + } + vr[*n - its + 1] -= *eps3 * rootn; +/* L270: */ + } + +/* Failure to find eigenvector in N iterations */ + + *info = 1; + +L280: + +/* Normalize eigenvector. */ + + vnorm = 0.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__3 = vnorm, r__4 = (r__1 = vr[i__], abs(r__1)) + (r__2 = vi[i__] + , abs(r__2)); + vnorm = f2cmax(r__3,r__4); +/* L290: */ + } + r__1 = 1.f / vnorm; + sscal_(n, &r__1, &vr[1], &c__1); + r__1 = 1.f / vnorm; + sscal_(n, &r__1, &vi[1], &c__1); + + } + + return 0; + +/* End of SLAEIN */ + +} /* slaein_ */ + diff --git a/lapack-netlib/SRC/slaev2.c b/lapack-netlib/SRC/slaev2.c new file mode 100644 index 000000000..cfb578e5c --- /dev/null +++ b/lapack-netlib/SRC/slaev2.c @@ -0,0 +1,619 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAEV2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) */ + +/* REAL A, B, C, CS1, RT1, RT2, SN1 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */ +/* > [ A B ] */ +/* > [ B C ]. */ +/* > On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */ +/* > eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */ +/* > eigenvector for RT1, giving the decomposition */ +/* > */ +/* > [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] */ +/* > [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL */ +/* > The (1,1) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL */ +/* > The (1,2) element and the conjugate of the (2,1) element of */ +/* > the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > The (2,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1 */ +/* > \verbatim */ +/* > RT1 is REAL */ +/* > The eigenvalue of larger absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2 */ +/* > \verbatim */ +/* > RT2 is REAL */ +/* > The eigenvalue of smaller absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS1 */ +/* > \verbatim */ +/* > CS1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN1 */ +/* > \verbatim */ +/* > SN1 is REAL */ +/* > The vector (CS1, SN1) is a unit right eigenvector for RT1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > RT1 is accurate to a few ulps barring over/underflow. */ +/* > */ +/* > RT2 may be inaccurate if there is massive cancellation in the */ +/* > determinant A*C-B*B; higher precision or correctly rounded or */ +/* > correctly truncated arithmetic would be needed to compute RT2 */ +/* > accurately in all cases. */ +/* > */ +/* > CS1 and SN1 are accurate to a few ulps barring over/underflow. */ +/* > */ +/* > Overflow is possible only if RT1 is within a factor of 5 of overflow. */ +/* > Underflow is harmless if the input data is 0 or exceeds */ +/* > underflow_threshold / macheps. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real * + rt2, real *cs1, real *sn1) +{ + /* System generated locals */ + real r__1; + + /* Local variables */ + real acmn, acmx, ab, df, cs, ct, tb, sm, tn, rt, adf, acs; + integer sgn1, sgn2; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Compute the eigenvalues */ + + sm = *a + *c__; + df = *a - *c__; + adf = abs(df); + tb = *b + *b; + ab = abs(tb); + if (abs(*a) > abs(*c__)) { + acmx = *a; + acmn = *c__; + } else { + acmx = *c__; + acmn = *a; + } + if (adf > ab) { +/* Computing 2nd power */ + r__1 = ab / adf; + rt = adf * sqrt(r__1 * r__1 + 1.f); + } else if (adf < ab) { +/* Computing 2nd power */ + r__1 = adf / ab; + rt = ab * sqrt(r__1 * r__1 + 1.f); + } else { + +/* Includes case AB=ADF=0 */ + + rt = ab * sqrt(2.f); + } + if (sm < 0.f) { + *rt1 = (sm - rt) * .5f; + sgn1 = -1; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else if (sm > 0.f) { + *rt1 = (sm + rt) * .5f; + sgn1 = 1; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else { + +/* Includes case RT1 = RT2 = 0 */ + + *rt1 = rt * .5f; + *rt2 = rt * -.5f; + sgn1 = 1; + } + +/* Compute the eigenvector */ + + if (df >= 0.f) { + cs = df + rt; + sgn2 = 1; + } else { + cs = df - rt; + sgn2 = -1; + } + acs = abs(cs); + if (acs > ab) { + ct = -tb / cs; + *sn1 = 1.f / sqrt(ct * ct + 1.f); + *cs1 = ct * *sn1; + } else { + if (ab == 0.f) { + *cs1 = 1.f; + *sn1 = 0.f; + } else { + tn = -cs / tb; + *cs1 = 1.f / sqrt(tn * tn + 1.f); + *sn1 = tn * *cs1; + } + } + if (sgn1 == sgn2) { + tn = *cs1; + *cs1 = -(*sn1); + *sn1 = tn; + } + return 0; + +/* End of SLAEV2 */ + +} /* slaev2_ */ + diff --git a/lapack-netlib/SRC/slaexc.c b/lapack-netlib/SRC/slaexc.c new file mode 100644 index 000000000..6ea3d79c0 --- /dev/null +++ b/lapack-netlib/SRC/slaexc.c @@ -0,0 +1,896 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonica +l form, by an orthogonal similarity transformation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAEXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, */ +/* INFO ) */ + +/* LOGICAL WANTQ */ +/* INTEGER INFO, J1, LDQ, LDT, N, N1, N2 */ +/* REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in */ +/* > an upper quasi-triangular matrix T by an orthogonal similarity */ +/* > transformation. */ +/* > */ +/* > T must be in Schur canonical form, that is, block upper triangular */ +/* > with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block */ +/* > has its diagonal elemnts equal and its off-diagonal elements of */ +/* > opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > = .TRUE. : accumulate the transformation in the matrix Q; */ +/* > = .FALSE.: do not accumulate the transformation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > On entry, the upper quasi-triangular matrix T, in Schur */ +/* > canonical form. */ +/* > On exit, the updated matrix T, again in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, if WANTQ is .TRUE., the orthogonal matrix Q. */ +/* > On exit, if WANTQ is .TRUE., the updated matrix Q. */ +/* > If WANTQ is .FALSE., Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The index of the first row of the first block T11. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > The order of the first block T11. N1 = 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N2 is INTEGER */ +/* > The order of the second block T22. N2 = 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > = 1: the transformed matrix T would be too far from Schur */ +/* > form; the blocks are not swapped and T and Q are */ +/* > unchanged. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaexc_(logical *wantq, integer *n, real *t, integer * + ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2, + real *work, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1; + real r__1, r__2, r__3; + + /* Local variables */ + integer ierr; + real temp; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + real d__[16] /* was [4][4] */; + integer k; + real u[3], scale, x[4] /* was [2][2] */, dnorm; + integer j2, j3, j4; + real xnorm, u1[3], u2[3]; + extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *, real *), slasy2_(logical *, + logical *, integer *, integer *, integer *, real *, integer *, + real *, integer *, real *, integer *, real *, real *, integer *, + real *, integer *); + integer nd; + real cs, t11, t22, t33, sn; + extern real slamch_(char *), slange_(char *, integer *, integer *, + real *, integer *, real *); + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *), slacpy_(char *, integer *, integer *, real *, integer *, + real *, integer *), slartg_(real *, real *, real *, real * + , real *); + real thresh; + extern /* Subroutine */ int slarfx_(char *, integer *, integer *, real *, + real *, real *, integer *, real *); + real smlnum, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0 || *n1 == 0 || *n2 == 0) { + return 0; + } + if (*j1 + *n1 > *n) { + return 0; + } + + j2 = *j1 + 1; + j3 = *j1 + 2; + j4 = *j1 + 3; + + if (*n1 == 1 && *n2 == 1) { + +/* Swap two 1-by-1 blocks. */ + + t11 = t[*j1 + *j1 * t_dim1]; + t22 = t[j2 + j2 * t_dim1]; + +/* Determine the transformation to perform the interchange. */ + + r__1 = t22 - t11; + slartg_(&t[*j1 + j2 * t_dim1], &r__1, &cs, &sn, &temp); + +/* Apply transformation to the matrix T. */ + + if (j3 <= *n) { + i__1 = *n - *j1 - 1; + srot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1], + ldt, &cs, &sn); + } + i__1 = *j1 - 1; + srot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1, + &cs, &sn); + + t[*j1 + *j1 * t_dim1] = t22; + t[j2 + j2 * t_dim1] = t11; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1, + &cs, &sn); + } + + } else { + +/* Swapping involves at least one 2-by-2 block. */ + +/* Copy the diagonal block of order N1+N2 to the local array D */ +/* and compute its norm. */ + + nd = *n1 + *n2; + slacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4); + dnorm = slange_("Max", &nd, &nd, d__, &c__4, &work[1]); + +/* Compute machine-dependent threshold for test for accepting */ +/* swap. */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; +/* Computing MAX */ + r__1 = eps * 10.f * dnorm; + thresh = f2cmax(r__1,smlnum); + +/* Solve T11*X - X*T22 = scale*T12 for X. */ + + slasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 + + (*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, & + scale, x, &c__2, &xnorm, &ierr); + +/* Swap the adjacent diagonal blocks. */ + + k = *n1 + *n1 + *n2 - 3; + switch (k) { + case 1: goto L10; + case 2: goto L20; + case 3: goto L30; + } + +L10: + +/* N1 = 1, N2 = 2: generate elementary reflector H so that: */ + +/* ( scale, X11, X12 ) H = ( 0, 0, * ) */ + + u[0] = scale; + u[1] = x[0]; + u[2] = x[2]; + slarfg_(&c__3, &u[2], u, &c__1, &tau); + u[2] = 1.f; + t11 = t[*j1 + *j1 * t_dim1]; + +/* Perform swap provisionally on diagonal block in D. */ + + slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + r__2 = abs(d__[2]), r__3 = abs(d__[6]), r__2 = f2cmax(r__2,r__3), r__3 = + (r__1 = d__[10] - t11, abs(r__1)); + if (f2cmax(r__2,r__3) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + i__1 = *n - *j1 + 1; + slarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + slarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); + + t[j3 + *j1 * t_dim1] = 0.f; + t[j3 + j2 * t_dim1] = 0.f; + t[j3 + j3 * t_dim1] = t11; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + slarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ + 1]); + } + goto L40; + +L20: + +/* N1 = 2, N2 = 1: generate elementary reflector H so that: */ + +/* H ( -X11 ) = ( * ) */ +/* ( -X21 ) = ( 0 ) */ +/* ( scale ) = ( 0 ) */ + + u[0] = -x[0]; + u[1] = -x[1]; + u[2] = scale; + slarfg_(&c__3, u, &u[1], &c__1, &tau); + u[0] = 1.f; + t33 = t[j3 + j3 * t_dim1]; + +/* Perform swap provisionally on diagonal block in D. */ + + slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + r__2 = abs(d__[1]), r__3 = abs(d__[2]), r__2 = f2cmax(r__2,r__3), r__3 = + (r__1 = d__[0] - t33, abs(r__1)); + if (f2cmax(r__2,r__3) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + slarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); + i__1 = *n - *j1; + slarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[ + 1]); + + t[*j1 + *j1 * t_dim1] = t33; + t[j2 + *j1 * t_dim1] = 0.f; + t[j3 + *j1 * t_dim1] = 0.f; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + slarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ + 1]); + } + goto L40; + +L30: + +/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so */ +/* that: */ + +/* H(2) H(1) ( -X11 -X12 ) = ( * * ) */ +/* ( -X21 -X22 ) ( 0 * ) */ +/* ( scale 0 ) ( 0 0 ) */ +/* ( 0 scale ) ( 0 0 ) */ + + u1[0] = -x[0]; + u1[1] = -x[1]; + u1[2] = scale; + slarfg_(&c__3, u1, &u1[1], &c__1, &tau1); + u1[0] = 1.f; + + temp = -tau1 * (x[2] + u1[1] * x[3]); + u2[0] = -temp * u1[1] - x[3]; + u2[1] = -temp * u1[2]; + u2[2] = scale; + slarfg_(&c__3, u2, &u2[1], &c__1, &tau2); + u2[0] = 1.f; + +/* Perform swap provisionally on diagonal block in D. */ + + slarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1]) + ; + slarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1]) + ; + slarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]); + slarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + r__1 = abs(d__[2]), r__2 = abs(d__[6]), r__1 = f2cmax(r__1,r__2), r__2 = + abs(d__[3]), r__1 = f2cmax(r__1,r__2), r__2 = abs(d__[7]); + if (f2cmax(r__1,r__2) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + i__1 = *n - *j1 + 1; + slarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + slarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[ + 1]); + i__1 = *n - *j1 + 1; + slarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, & + work[1]); + slarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1] + ); + + t[j3 + *j1 * t_dim1] = 0.f; + t[j3 + j2 * t_dim1] = 0.f; + t[j4 + *j1 * t_dim1] = 0.f; + t[j4 + j2 * t_dim1] = 0.f; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + slarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, & + work[1]); + slarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[ + 1]); + } + +L40: + + if (*n2 == 2) { + +/* Standardize new 2-by-2 block T11 */ + + slanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + * + j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, & + wi2, &cs, &sn); + i__1 = *n - *j1 - 1; + srot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2) + * t_dim1], ldt, &cs, &sn); + i__1 = *j1 - 1; + srot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], & + c__1, &cs, &sn); + } + } + + if (*n1 == 2) { + +/* Standardize new 2-by-2 block T22 */ + + j3 = *j1 + *n2; + j4 = j3 + 1; + slanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 * + t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, & + cs, &sn); + if (j3 + 2 <= *n) { + i__1 = *n - j3 - 1; + srot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2) + * t_dim1], ldt, &cs, &sn); + } + i__1 = j3 - 1; + srot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + srot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], & + c__1, &cs, &sn); + } + } + + } + return 0; + +/* Exit with INFO = 1 if swap was rejected. */ + +L50: + *info = 1; + return 0; + +/* End of SLAEXC */ + +} /* slaexc_ */ + diff --git a/lapack-netlib/SRC/slag2.c b/lapack-netlib/SRC/slag2.c new file mode 100644 index 000000000..912748852 --- /dev/null +++ b/lapack-netlib/SRC/slag2.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 \b SLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as nece +ssary to avoid over-/underflow. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAG2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, */ +/* WR2, WI ) */ + +/* INTEGER LDA, LDB */ +/* REAL SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 */ +/* REAL A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue */ +/* > problem A - w B, with scaling as necessary to avoid over-/underflow. */ +/* > */ +/* > The scaling factor "s" results in a modified eigenvalue equation */ +/* > */ +/* > s A - w B */ +/* > */ +/* > where s is a non-negative scaling factor chosen so that w, w B, */ +/* > and s A do not overflow and, if possible, do not underflow, either. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, 2) */ +/* > On entry, the 2 x 2 matrix A. It is assumed that its 1-norm */ +/* > is less than 1/SAFMIN. Entries less than */ +/* > sqrt(SAFMIN)*norm(A) are subject to being treated as zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, 2) */ +/* > On entry, the 2 x 2 upper triangular matrix B. It is */ +/* > assumed that the one-norm of B is less than 1/SAFMIN. The */ +/* > diagonals should be at least sqrt(SAFMIN) times the largest */ +/* > element of B (in absolute value); if a diagonal is smaller */ +/* > than that, then +/- sqrt(SAFMIN) will be used instead of */ +/* > that diagonal. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SAFMIN */ +/* > \verbatim */ +/* > SAFMIN is REAL */ +/* > The smallest positive number s.t. 1/SAFMIN does not */ +/* > overflow. (This should always be SLAMCH('S') -- it is an */ +/* > argument in order to avoid having to call SLAMCH frequently.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE1 */ +/* > \verbatim */ +/* > SCALE1 is REAL */ +/* > A scaling factor used to avoid over-/underflow in the */ +/* > eigenvalue equation which defines the first eigenvalue. If */ +/* > the eigenvalues are complex, then the eigenvalues are */ +/* > ( WR1 +/- WI i ) / SCALE1 (which may lie outside the */ +/* > exponent range of the machine), SCALE1=SCALE2, and SCALE1 */ +/* > will always be positive. If the eigenvalues are real, then */ +/* > the first (real) eigenvalue is WR1 / SCALE1 , but this may */ +/* > overflow or underflow, and in fact, SCALE1 may be zero or */ +/* > less than the underflow threshold if the exact eigenvalue */ +/* > is sufficiently large. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE2 */ +/* > \verbatim */ +/* > SCALE2 is REAL */ +/* > A scaling factor used to avoid over-/underflow in the */ +/* > eigenvalue equation which defines the second eigenvalue. If */ +/* > the eigenvalues are complex, then SCALE2=SCALE1. If the */ +/* > eigenvalues are real, then the second (real) eigenvalue is */ +/* > WR2 / SCALE2 , but this may overflow or underflow, and in */ +/* > fact, SCALE2 may be zero or less than the underflow */ +/* > threshold if the exact eigenvalue is sufficiently large. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR1 */ +/* > \verbatim */ +/* > WR1 is REAL */ +/* > If the eigenvalue is real, then WR1 is SCALE1 times the */ +/* > eigenvalue closest to the (2,2) element of A B**(-1). If the */ +/* > eigenvalue is complex, then WR1=WR2 is SCALE1 times the real */ +/* > part of the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR2 */ +/* > \verbatim */ +/* > WR2 is REAL */ +/* > If the eigenvalue is real, then WR2 is SCALE2 times the */ +/* > other eigenvalue. If the eigenvalue is complex, then */ +/* > WR1=WR2 is SCALE1 times the real part of the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is REAL */ +/* > If the eigenvalue is real, then WI is zero. If the */ +/* > eigenvalue is complex, then WI is SCALE1 times the imaginary */ +/* > part of the eigenvalues. WI will always be non-negative. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slag2_(real *a, integer *lda, real *b, integer *ldb, + real *safmin, real *scale1, real *scale2, real *wr1, real *wr2, real * + wi) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset; + real r__1, r__2, r__3, r__4, r__5, r__6; + + /* Local variables */ + real diff, bmin, wbig, wabs, wdet, r__, binv11, binv22, discr, anorm, + bnorm, bsize, shift, c1, c2, c3, c4, c5, rtmin, rtmax, wsize, s1, + s2, a11, a12, a21, a22, b11, b12, b22, ascale, bscale, pp, qq, ss, + wscale, safmax, wsmall, as11, as12, as22, sum, abi22; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + 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 */ + rtmin = sqrt(*safmin); + rtmax = 1.f / rtmin; + safmax = 1.f / *safmin; + +/* Scale A */ + +/* Computing MAX */ + r__5 = (r__1 = a[a_dim1 + 1], abs(r__1)) + (r__2 = a[a_dim1 + 2], abs( + r__2)), r__6 = (r__3 = a[(a_dim1 << 1) + 1], abs(r__3)) + (r__4 = + a[(a_dim1 << 1) + 2], abs(r__4)), r__5 = f2cmax(r__5,r__6); + anorm = f2cmax(r__5,*safmin); + ascale = 1.f / anorm; + a11 = ascale * a[a_dim1 + 1]; + a21 = ascale * a[a_dim1 + 2]; + a12 = ascale * a[(a_dim1 << 1) + 1]; + a22 = ascale * a[(a_dim1 << 1) + 2]; + +/* Perturb B if necessary to insure non-singularity */ + + b11 = b[b_dim1 + 1]; + b12 = b[(b_dim1 << 1) + 1]; + b22 = b[(b_dim1 << 1) + 2]; +/* Computing MAX */ + r__1 = abs(b11), r__2 = abs(b12), r__1 = f2cmax(r__1,r__2), r__2 = abs(b22), + r__1 = f2cmax(r__1,r__2); + bmin = rtmin * f2cmax(r__1,rtmin); + if (abs(b11) < bmin) { + b11 = r_sign(&bmin, &b11); + } + if (abs(b22) < bmin) { + b22 = r_sign(&bmin, &b22); + } + +/* Scale B */ + +/* Computing MAX */ + r__1 = abs(b11), r__2 = abs(b12) + abs(b22), r__1 = f2cmax(r__1,r__2); + bnorm = f2cmax(r__1,*safmin); +/* Computing MAX */ + r__1 = abs(b11), r__2 = abs(b22); + bsize = f2cmax(r__1,r__2); + bscale = 1.f / bsize; + b11 *= bscale; + b12 *= bscale; + b22 *= bscale; + +/* Compute larger eigenvalue by method described by C. van Loan */ + +/* ( AS is A shifted by -SHIFT*B ) */ + + binv11 = 1.f / b11; + binv22 = 1.f / b22; + s1 = a11 * binv11; + s2 = a22 * binv22; + if (abs(s1) <= abs(s2)) { + as12 = a12 - s1 * b12; + as22 = a22 - s1 * b22; + ss = a21 * (binv11 * binv22); + abi22 = as22 * binv22 - ss * b12; + pp = abi22 * .5f; + shift = s1; + } else { + as12 = a12 - s2 * b12; + as11 = a11 - s2 * b11; + ss = a21 * (binv11 * binv22); + abi22 = -ss * b12; + pp = (as11 * binv11 + abi22) * .5f; + shift = s2; + } + qq = ss * as12; + if ((r__1 = pp * rtmin, abs(r__1)) >= 1.f) { +/* Computing 2nd power */ + r__1 = rtmin * pp; + discr = r__1 * r__1 + qq * *safmin; + r__ = sqrt((abs(discr))) * rtmax; + } else { +/* Computing 2nd power */ + r__1 = pp; + if (r__1 * r__1 + abs(qq) <= *safmin) { +/* Computing 2nd power */ + r__1 = rtmax * pp; + discr = r__1 * r__1 + qq * safmax; + r__ = sqrt((abs(discr))) * rtmin; + } else { +/* Computing 2nd power */ + r__1 = pp; + discr = r__1 * r__1 + qq; + r__ = sqrt((abs(discr))); + } + } + +/* Note: the test of R in the following IF is to cover the case when */ +/* DISCR is small and negative and is flushed to zero during */ +/* the calculation of R. On machines which have a consistent */ +/* flush-to-zero threshold and handle numbers above that */ +/* threshold correctly, it would not be necessary. */ + + if (discr >= 0.f || r__ == 0.f) { + sum = pp + r_sign(&r__, &pp); + diff = pp - r_sign(&r__, &pp); + wbig = shift + sum; + +/* Compute smaller eigenvalue */ + + wsmall = shift + diff; +/* Computing MAX */ + r__1 = abs(wsmall); + if (abs(wbig) * .5f > f2cmax(r__1,*safmin)) { + wdet = (a11 * a22 - a12 * a21) * (binv11 * binv22); + wsmall = wdet / wbig; + } + +/* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) */ +/* for WR1. */ + + if (pp > abi22) { + *wr1 = f2cmin(wbig,wsmall); + *wr2 = f2cmax(wbig,wsmall); + } else { + *wr1 = f2cmax(wbig,wsmall); + *wr2 = f2cmin(wbig,wsmall); + } + *wi = 0.f; + } else { + +/* Complex eigenvalues */ + + *wr1 = shift + pp; + *wr2 = *wr1; + *wi = r__; + } + +/* Further scaling to avoid underflow and overflow in computing */ +/* SCALE1 and overflow in computing w*B. */ + +/* This scale factor (WSCALE) is bounded from above using C1 and C2, */ +/* and from below using C3 and C4. */ +/* C1 implements the condition s A must never overflow. */ +/* C2 implements the condition w B must never overflow. */ +/* C3, with C2, */ +/* implement the condition that s A - w B must never overflow. */ +/* C4 implements the condition s should not underflow. */ +/* C5 implements the condition f2cmax(s,|w|) should be at least 2. */ + + c1 = bsize * (*safmin * f2cmax(1.f,ascale)); + c2 = *safmin * f2cmax(1.f,bnorm); + c3 = bsize * *safmin; + if (ascale <= 1.f && bsize <= 1.f) { +/* Computing MIN */ + r__1 = 1.f, r__2 = ascale / *safmin * bsize; + c4 = f2cmin(r__1,r__2); + } else { + c4 = 1.f; + } + if (ascale <= 1.f || bsize <= 1.f) { +/* Computing MIN */ + r__1 = 1.f, r__2 = ascale * bsize; + c5 = f2cmin(r__1,r__2); + } else { + c5 = 1.f; + } + +/* Scale first eigenvalue */ + + wabs = abs(*wr1) + abs(*wi); +/* Computing MAX */ +/* Computing MIN */ + r__3 = c4, r__4 = f2cmax(wabs,c5) * .5f; + r__1 = f2cmax(*safmin,c1), r__2 = (wabs * c2 + c3) * 1.0000100000000001f, + r__1 = f2cmax(r__1,r__2), r__2 = f2cmin(r__3,r__4); + wsize = f2cmax(r__1,r__2); + if (wsize != 1.f) { + wscale = 1.f / wsize; + if (wsize > 1.f) { + *scale1 = f2cmax(ascale,bsize) * wscale * f2cmin(ascale,bsize); + } else { + *scale1 = f2cmin(ascale,bsize) * wscale * f2cmax(ascale,bsize); + } + *wr1 *= wscale; + if (*wi != 0.f) { + *wi *= wscale; + *wr2 = *wr1; + *scale2 = *scale1; + } + } else { + *scale1 = ascale * bsize; + *scale2 = *scale1; + } + +/* Scale second eigenvalue (if real) */ + + if (*wi == 0.f) { +/* Computing MAX */ +/* Computing MIN */ +/* Computing MAX */ + r__5 = abs(*wr2); + r__3 = c4, r__4 = f2cmax(r__5,c5) * .5f; + r__1 = f2cmax(*safmin,c1), r__2 = (abs(*wr2) * c2 + c3) * + 1.0000100000000001f, r__1 = f2cmax(r__1,r__2), r__2 = f2cmin(r__3, + r__4); + wsize = f2cmax(r__1,r__2); + if (wsize != 1.f) { + wscale = 1.f / wsize; + if (wsize > 1.f) { + *scale2 = f2cmax(ascale,bsize) * wscale * f2cmin(ascale,bsize); + } else { + *scale2 = f2cmin(ascale,bsize) * wscale * f2cmax(ascale,bsize); + } + *wr2 *= wscale; + } else { + *scale2 = ascale * bsize; + } + } + +/* End of SLAG2 */ + + return 0; +} /* slag2_ */ + diff --git a/lapack-netlib/SRC/slag2d.c b/lapack-netlib/SRC/slag2d.c new file mode 100644 index 000000000..3cf476461 --- /dev/null +++ b/lapack-netlib/SRC/slag2d.c @@ -0,0 +1,535 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAG2D converts a single precision matrix to a double precision matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAG2D + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO ) */ + +/* INTEGER INFO, LDA, LDSA, M, N */ +/* REAL SA( LDSA, * ) */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE */ +/* > PRECISION matrix, A. */ +/* > */ +/* > Note that while it is possible to overflow while converting */ +/* > from double to single, it is not possible to overflow when */ +/* > converting from single to double. */ +/* > */ +/* > This is an auxiliary routine so there is no argument checking. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of lines of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SA */ +/* > \verbatim */ +/* > SA is REAL array, dimension (LDSA,N) */ +/* > On entry, the M-by-N coefficient matrix SA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDSA */ +/* > \verbatim */ +/* > LDSA is INTEGER */ +/* > The leading dimension of the array SA. LDSA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On exit, the M-by-N coefficient matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slag2d_(integer *m, integer *n, real *sa, integer *ldsa, + doublereal *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + sa_dim1 = *ldsa; + sa_offset = 1 + sa_dim1 * 1; + sa -= sa_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = sa[i__ + j * sa_dim1]; +/* L10: */ + } +/* L20: */ + } + return 0; + +/* End of SLAG2D */ + +} /* slag2d_ */ + diff --git a/lapack-netlib/SRC/slags2.c b/lapack-netlib/SRC/slags2.c new file mode 100644 index 000000000..74c9372bb --- /dev/null +++ b/lapack-netlib/SRC/slags2.c @@ -0,0 +1,748 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B su +ch that the rows of the transformed A and B are parallel. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAGS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, */ +/* SNV, CSQ, SNQ ) */ + +/* LOGICAL UPPER */ +/* REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, */ +/* $ SNU, SNV */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such */ +/* > that if ( UPPER ) then */ +/* > */ +/* > U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) */ +/* > ( 0 A3 ) ( x x ) */ +/* > and */ +/* > V**T*B*Q = V**T *( B1 B2 )*Q = ( x 0 ) */ +/* > ( 0 B3 ) ( x x ) */ +/* > */ +/* > or if ( .NOT.UPPER ) then */ +/* > */ +/* > U**T *A*Q = U**T *( A1 0 )*Q = ( x x ) */ +/* > ( A2 A3 ) ( 0 x ) */ +/* > and */ +/* > V**T*B*Q = V**T*( B1 0 )*Q = ( x x ) */ +/* > ( B2 B3 ) ( 0 x ) */ +/* > */ +/* > The rows of the transformed A and B are parallel, where */ +/* > */ +/* > U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) */ +/* > ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) */ +/* > */ +/* > Z**T denotes the transpose of Z. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPPER */ +/* > \verbatim */ +/* > UPPER is LOGICAL */ +/* > = .TRUE.: the input matrices A and B are upper triangular. */ +/* > = .FALSE.: the input matrices A and B are lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A1 */ +/* > \verbatim */ +/* > A1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A2 */ +/* > \verbatim */ +/* > A2 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A3 */ +/* > \verbatim */ +/* > A3 is REAL */ +/* > On entry, A1, A2 and A3 are elements of the input 2-by-2 */ +/* > upper (lower) triangular matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B1 */ +/* > \verbatim */ +/* > B1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B2 */ +/* > \verbatim */ +/* > B2 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B3 */ +/* > \verbatim */ +/* > B3 is REAL */ +/* > On entry, B1, B2 and B3 are elements of the input 2-by-2 */ +/* > upper (lower) triangular matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSU */ +/* > \verbatim */ +/* > CSU is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNU */ +/* > \verbatim */ +/* > SNU is REAL */ +/* > The desired orthogonal matrix U. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSV */ +/* > \verbatim */ +/* > CSV is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNV */ +/* > \verbatim */ +/* > SNV is REAL */ +/* > The desired orthogonal matrix V. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSQ */ +/* > \verbatim */ +/* > CSQ is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNQ */ +/* > \verbatim */ +/* > SNQ is REAL */ +/* > The desired orthogonal matrix Q. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slags2_(logical *upper, real *a1, real *a2, real *a3, + real *b1, real *b2, real *b3, real *csu, real *snu, real *csv, real * + snv, real *csq, real *snq) +{ + /* System generated locals */ + real r__1; + + /* Local variables */ + real aua11, aua12, aua21, aua22, avb11, avb12, avb21, avb22, ua11r, ua22r, + vb11r, vb22r, a, b, c__, d__, r__, s1, s2; + extern /* Subroutine */ int slasv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *), slartg_(real *, real *, real *, + real *, real *); + real ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22, csl, csr, snl, snr; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + if (*upper) { + +/* Input matrices A and B are upper triangular matrices */ + +/* Form matrix C = A*adj(B) = ( a b ) */ +/* ( 0 d ) */ + + a = *a1 * *b3; + d__ = *a3 * *b1; + b = *a2 * *b1 - *a1 * *b2; + +/* The SVD of real 2-by-2 triangular C */ + +/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */ +/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */ + + slasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl); + + if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) { + +/* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, */ +/* and (1,2) element of |U|**T *|A| and |V|**T *|B|. */ + + ua11r = csl * *a1; + ua12 = csl * *a2 + snl * *a3; + + vb11r = csr * *b1; + vb12 = csr * *b2 + snr * *b3; + + aua12 = abs(csl) * abs(*a2) + abs(snl) * abs(*a3); + avb12 = abs(csr) * abs(*b2) + abs(snr) * abs(*b3); + +/* zero (1,2) elements of U**T *A and V**T *B */ + + if (abs(ua11r) + abs(ua12) != 0.f) { + if (aua12 / (abs(ua11r) + abs(ua12)) <= avb12 / (abs(vb11r) + + abs(vb12))) { + r__1 = -ua11r; + slartg_(&r__1, &ua12, csq, snq, &r__); + } else { + r__1 = -vb11r; + slartg_(&r__1, &vb12, csq, snq, &r__); + } + } else { + r__1 = -vb11r; + slartg_(&r__1, &vb12, csq, snq, &r__); + } + + *csu = csl; + *snu = -snl; + *csv = csr; + *snv = -snr; + + } else { + +/* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, */ +/* and (2,2) element of |U|**T *|A| and |V|**T *|B|. */ + + ua21 = -snl * *a1; + ua22 = -snl * *a2 + csl * *a3; + + vb21 = -snr * *b1; + vb22 = -snr * *b2 + csr * *b3; + + aua22 = abs(snl) * abs(*a2) + abs(csl) * abs(*a3); + avb22 = abs(snr) * abs(*b2) + abs(csr) * abs(*b3); + +/* zero (2,2) elements of U**T*A and V**T*B, and then swap. */ + + if (abs(ua21) + abs(ua22) != 0.f) { + if (aua22 / (abs(ua21) + abs(ua22)) <= avb22 / (abs(vb21) + + abs(vb22))) { + r__1 = -ua21; + slartg_(&r__1, &ua22, csq, snq, &r__); + } else { + r__1 = -vb21; + slartg_(&r__1, &vb22, csq, snq, &r__); + } + } else { + r__1 = -vb21; + slartg_(&r__1, &vb22, csq, snq, &r__); + } + + *csu = snl; + *snu = csl; + *csv = snr; + *snv = csr; + + } + + } else { + +/* Input matrices A and B are lower triangular matrices */ + +/* Form matrix C = A*adj(B) = ( a 0 ) */ +/* ( c d ) */ + + a = *a1 * *b3; + d__ = *a3 * *b1; + c__ = *a2 * *b3 - *a3 * *b2; + +/* The SVD of real 2-by-2 triangular C */ + +/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */ +/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */ + + slasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl); + + if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) { + +/* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, */ +/* and (2,1) element of |U|**T *|A| and |V|**T *|B|. */ + + ua21 = -snr * *a1 + csr * *a2; + ua22r = csr * *a3; + + vb21 = -snl * *b1 + csl * *b2; + vb22r = csl * *b3; + + aua21 = abs(snr) * abs(*a1) + abs(csr) * abs(*a2); + avb21 = abs(snl) * abs(*b1) + abs(csl) * abs(*b2); + +/* zero (2,1) elements of U**T *A and V**T *B. */ + + if (abs(ua21) + abs(ua22r) != 0.f) { + if (aua21 / (abs(ua21) + abs(ua22r)) <= avb21 / (abs(vb21) + + abs(vb22r))) { + slartg_(&ua22r, &ua21, csq, snq, &r__); + } else { + slartg_(&vb22r, &vb21, csq, snq, &r__); + } + } else { + slartg_(&vb22r, &vb21, csq, snq, &r__); + } + + *csu = csr; + *snu = -snr; + *csv = csl; + *snv = -snl; + + } else { + +/* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, */ +/* and (1,1) element of |U|**T *|A| and |V|**T *|B|. */ + + ua11 = csr * *a1 + snr * *a2; + ua12 = snr * *a3; + + vb11 = csl * *b1 + snl * *b2; + vb12 = snl * *b3; + + aua11 = abs(csr) * abs(*a1) + abs(snr) * abs(*a2); + avb11 = abs(csl) * abs(*b1) + abs(snl) * abs(*b2); + +/* zero (1,1) elements of U**T*A and V**T*B, and then swap. */ + + if (abs(ua11) + abs(ua12) != 0.f) { + if (aua11 / (abs(ua11) + abs(ua12)) <= avb11 / (abs(vb11) + + abs(vb12))) { + slartg_(&ua12, &ua11, csq, snq, &r__); + } else { + slartg_(&vb12, &vb11, csq, snq, &r__); + } + } else { + slartg_(&vb12, &vb11, csq, snq, &r__); + } + + *csu = snr; + *snu = csr; + *csv = snl; + *snv = csl; + + } + + } + + return 0; + +/* End of SLAGS2 */ + +} /* slags2_ */ + diff --git a/lapack-netlib/SRC/slagtf.c b/lapack-netlib/SRC/slagtf.c new file mode 100644 index 000000000..4392bd8a4 --- /dev/null +++ b/lapack-netlib/SRC/slagtf.c @@ -0,0 +1,660 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, + and λ a scalar, using partial pivoting with row interchanges. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAGTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) */ + +/* INTEGER INFO, N */ +/* REAL LAMBDA, TOL */ +/* INTEGER IN( * ) */ +/* REAL A( * ), B( * ), C( * ), D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n */ +/* > tridiagonal matrix and lambda is a scalar, as */ +/* > */ +/* > T - lambda*I = PLU, */ +/* > */ +/* > where P is a permutation matrix, L is a unit lower tridiagonal matrix */ +/* > with at most one non-zero sub-diagonal elements per column and U is */ +/* > an upper triangular matrix with at most two non-zero super-diagonal */ +/* > elements per column. */ +/* > */ +/* > The factorization is obtained by Gaussian elimination with partial */ +/* > pivoting and implicit row scaling. */ +/* > */ +/* > The parameter LAMBDA is included in the routine so that SLAGTF may */ +/* > be used, in conjunction with SLAGTS, to obtain eigenvectors of T by */ +/* > inverse iteration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (N) */ +/* > On entry, A must contain the diagonal elements of T. */ +/* > */ +/* > On exit, A is overwritten by the n diagonal elements of the */ +/* > upper triangular matrix U of the factorization of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LAMBDA */ +/* > \verbatim */ +/* > LAMBDA is REAL */ +/* > On entry, the scalar lambda. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (N-1) */ +/* > On entry, B must contain the (n-1) super-diagonal elements of */ +/* > T. */ +/* > */ +/* > On exit, B is overwritten by the (n-1) super-diagonal */ +/* > elements of the matrix U of the factorization of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N-1) */ +/* > On entry, C must contain the (n-1) sub-diagonal elements of */ +/* > T. */ +/* > */ +/* > On exit, C is overwritten by the (n-1) sub-diagonal elements */ +/* > of the matrix L of the factorization of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOL */ +/* > \verbatim */ +/* > TOL is REAL */ +/* > On entry, a relative tolerance used to indicate whether or */ +/* > not the matrix (T - lambda*I) is nearly singular. TOL should */ +/* > normally be chose as approximately the largest relative error */ +/* > in the elements of T. For example, if the elements of T are */ +/* > correct to about 4 significant figures, then TOL should be */ +/* > set to about 5*10**(-4). If TOL is supplied as less than eps, */ +/* > where eps is the relative machine precision, then the value */ +/* > eps is used in place of TOL. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N-2) */ +/* > On exit, D is overwritten by the (n-2) second super-diagonal */ +/* > elements of the matrix U of the factorization of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IN */ +/* > \verbatim */ +/* > IN is INTEGER array, dimension (N) */ +/* > On exit, IN contains details of the permutation matrix P. If */ +/* > an interchange occurred at the kth step of the elimination, */ +/* > then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) */ +/* > returns the smallest positive integer j such that */ +/* > */ +/* > abs( u(j,j) ) <= norm( (T - lambda*I)(j) )*TOL, */ +/* > */ +/* > where norm( A(j) ) denotes the sum of the absolute values of */ +/* > the jth row of the matrix A. If no such j exists then IN(n) */ +/* > is returned as zero. If IN(n) is returned as positive, then a */ +/* > diagonal element of U is small, indicating that */ +/* > (T - lambda*I) is singular or nearly singular, */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the kth argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slagtf_(integer *n, real *a, real *lambda, real *b, real + *c__, real *tol, real *d__, integer *in, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real temp, mult; + integer k; + real scale1, scale2, tl; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real eps, piv1, piv2; + + +/* -- 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 */ + --in; + --d__; + --c__; + --b; + --a; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("SLAGTF", &i__1, (ftnlen)6); + return 0; + } + + if (*n == 0) { + return 0; + } + + a[1] -= *lambda; + in[*n] = 0; + if (*n == 1) { + if (a[1] == 0.f) { + in[1] = 1; + } + return 0; + } + + eps = slamch_("Epsilon"); + + tl = f2cmax(*tol,eps); + scale1 = abs(a[1]) + abs(b[1]); + i__1 = *n - 1; + for (k = 1; k <= i__1; ++k) { + a[k + 1] -= *lambda; + scale2 = (r__1 = c__[k], abs(r__1)) + (r__2 = a[k + 1], abs(r__2)); + if (k < *n - 1) { + scale2 += (r__1 = b[k + 1], abs(r__1)); + } + if (a[k] == 0.f) { + piv1 = 0.f; + } else { + piv1 = (r__1 = a[k], abs(r__1)) / scale1; + } + if (c__[k] == 0.f) { + in[k] = 0; + piv2 = 0.f; + scale1 = scale2; + if (k < *n - 1) { + d__[k] = 0.f; + } + } else { + piv2 = (r__1 = c__[k], abs(r__1)) / scale2; + if (piv2 <= piv1) { + in[k] = 0; + scale1 = scale2; + c__[k] /= a[k]; + a[k + 1] -= c__[k] * b[k]; + if (k < *n - 1) { + d__[k] = 0.f; + } + } else { + in[k] = 1; + mult = a[k] / c__[k]; + a[k] = c__[k]; + temp = a[k + 1]; + a[k + 1] = b[k] - mult * temp; + if (k < *n - 1) { + d__[k] = b[k + 1]; + b[k + 1] = -mult * d__[k]; + } + b[k] = temp; + c__[k] = mult; + } + } + if (f2cmax(piv1,piv2) <= tl && in[*n] == 0) { + in[*n] = k; + } +/* L10: */ + } + if ((r__1 = a[*n], abs(r__1)) <= scale1 * tl && in[*n] == 0) { + in[*n] = *n; + } + + return 0; + +/* End of SLAGTF */ + +} /* slagtf_ */ + diff --git a/lapack-netlib/SRC/slagtm.c b/lapack-netlib/SRC/slagtm.c new file mode 100644 index 000000000..e487dac80 --- /dev/null +++ b/lapack-netlib/SRC/slagtm.c @@ -0,0 +1,704 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matr +ix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAGTM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, */ +/* B, LDB ) */ + +/* CHARACTER TRANS */ +/* INTEGER LDB, LDX, N, NRHS */ +/* REAL ALPHA, BETA */ +/* REAL B( LDB, * ), D( * ), DL( * ), DU( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAGTM performs a matrix-vector product of the form */ +/* > */ +/* > B := alpha * A * X + beta * B */ +/* > */ +/* > where A is a tridiagonal matrix of order N, B and X are N by NRHS */ +/* > matrices, and alpha and beta are real scalars, each of which may be */ +/* > 0., 1., or -1. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': No transpose, B := alpha * A * X + beta * B */ +/* > = 'T': Transpose, B := alpha * A'* X + beta * B */ +/* > = 'C': Conjugate transpose = Transpose */ +/* > \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 X and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */ +/* > it is assumed to be 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is REAL array, dimension (N-1) */ +/* > The (n-1) sub-diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is REAL array, dimension (N-1) */ +/* > The (n-1) super-diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > The N by NRHS matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is REAL */ +/* > The scalar beta. BETA must be 0., 1., or -1.; otherwise, */ +/* > it is assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the N by NRHS matrix B. */ +/* > On exit, B is overwritten by the matrix expression */ +/* > B := alpha * A * X + beta * B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(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 realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slagtm_(char *trans, integer *n, integer *nrhs, real * + alpha, real *dl, real *d__, real *du, real *x, integer *ldx, real * + beta, real *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --dl; + --d__; + --du; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (*n == 0) { + return 0; + } + +/* Multiply B by BETA if BETA.NE.1. */ + + if (*beta == 0.f) { + 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] = 0.f; +/* L10: */ + } +/* L20: */ + } + } else if (*beta == -1.f) { + 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] = -b[i__ + j * b_dim1]; +/* L30: */ + } +/* L40: */ + } + } + + if (*alpha == 1.f) { + if (lsame_(trans, "N")) { + +/* Compute B := B + A*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * + x_dim1 + 1] + du[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] + dl[*n - 1] * x[* + n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + dl[i__ - + 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[ + i__ + j * x_dim1] + du[i__] * x[i__ + 1 + j * + x_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + +/* Compute B := B + A**T*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * + x_dim1 + 1] + dl[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] + du[*n - 1] * x[* + n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + du[i__ - + 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[ + i__ + j * x_dim1] + dl[i__] * x[i__ + 1 + j * + x_dim1]; +/* L70: */ + } + } +/* L80: */ + } + } + } else if (*alpha == -1.f) { + if (lsame_(trans, "N")) { + +/* Compute B := B - A*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * + x_dim1 + 1] - du[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] - dl[*n - 1] * x[* + n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - dl[i__ - + 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[ + i__ + j * x_dim1] - du[i__] * x[i__ + 1 + j * + x_dim1]; +/* L90: */ + } + } +/* L100: */ + } + } else { + +/* Compute B := B - A**T*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * + x_dim1 + 1] - dl[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] - du[*n - 1] * x[* + n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - du[i__ - + 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[ + i__ + j * x_dim1] - dl[i__] * x[i__ + 1 + j * + x_dim1]; +/* L110: */ + } + } +/* L120: */ + } + } + } + return 0; + +/* End of SLAGTM */ + +} /* slagtm_ */ + diff --git a/lapack-netlib/SRC/slagts.c b/lapack-netlib/SRC/slagts.c new file mode 100644 index 000000000..00e54bf84 --- /dev/null +++ b/lapack-netlib/SRC/slagts.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 \b SLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridia +gonal matrix and λ a scalar, using the LU factorization computed by slagtf. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAGTS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) */ + +/* INTEGER INFO, JOB, N */ +/* REAL TOL */ +/* INTEGER IN( * ) */ +/* REAL A( * ), B( * ), C( * ), D( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAGTS may be used to solve one of the systems of equations */ +/* > */ +/* > (T - lambda*I)*x = y or (T - lambda*I)**T*x = y, */ +/* > */ +/* > where T is an n by n tridiagonal matrix, for x, following the */ +/* > factorization of (T - lambda*I) as */ +/* > */ +/* > (T - lambda*I) = P*L*U , */ +/* > */ +/* > by routine SLAGTF. The choice of equation to be solved is */ +/* > controlled by the argument JOB, and in each case there is an option */ +/* > to perturb zero or very small diagonal elements of U, this option */ +/* > being intended for use in applications such as inverse iteration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is INTEGER */ +/* > Specifies the job to be performed by SLAGTS as follows: */ +/* > = 1: The equations (T - lambda*I)x = y are to be solved, */ +/* > but diagonal elements of U are not to be perturbed. */ +/* > = -1: The equations (T - lambda*I)x = y are to be solved */ +/* > and, if overflow would otherwise occur, the diagonal */ +/* > elements of U are to be perturbed. See argument TOL */ +/* > below. */ +/* > = 2: The equations (T - lambda*I)**Tx = y are to be solved, */ +/* > but diagonal elements of U are not to be perturbed. */ +/* > = -2: The equations (T - lambda*I)**Tx = y are to be solved */ +/* > and, if overflow would otherwise occur, the diagonal */ +/* > elements of U are to be perturbed. See argument TOL */ +/* > below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (N) */ +/* > On entry, A must contain the diagonal elements of U as */ +/* > returned from SLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (N-1) */ +/* > On entry, B must contain the first super-diagonal elements of */ +/* > U as returned from SLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N-1) */ +/* > On entry, C must contain the sub-diagonal elements of L as */ +/* > returned from SLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N-2) */ +/* > On entry, D must contain the second super-diagonal elements */ +/* > of U as returned from SLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IN */ +/* > \verbatim */ +/* > IN is INTEGER array, dimension (N) */ +/* > On entry, IN must contain details of the matrix P as returned */ +/* > from SLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension (N) */ +/* > On entry, the right hand side vector y. */ +/* > On exit, Y is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] TOL */ +/* > \verbatim */ +/* > TOL is REAL */ +/* > On entry, with JOB < 0, TOL should be the minimum */ +/* > perturbation to be made to very small diagonal elements of U. */ +/* > TOL should normally be chosen as about eps*norm(U), where eps */ +/* > is the relative machine precision, but if TOL is supplied as */ +/* > non-positive, then it is reset to eps*f2cmax( abs( u(i,j) ) ). */ +/* > If JOB > 0 then TOL is not referenced. */ +/* > */ +/* > On exit, TOL is changed as described above, only if TOL is */ +/* > non-positive on entry. Otherwise TOL is unchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: overflow would occur when computing the INFO(th) */ +/* > element of the solution vector x. This can only occur */ +/* > when JOB is supplied as positive and either means */ +/* > that a diagonal element of U is very small, or that */ +/* > the elements of the right-hand side vector y are very */ +/* > large. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slagts_(integer *job, integer *n, real *a, real *b, real + *c__, real *d__, integer *in, real *y, real *tol, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2, r__3, r__4, r__5; + + /* Local variables */ + real temp, pert; + integer k; + real absak, sfmin, ak; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum, eps; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --y; + --in; + --d__; + --c__; + --b; + --a; + + /* Function Body */ + *info = 0; + if (abs(*job) > 2 || *job == 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAGTS", &i__1, (ftnlen)6); + return 0; + } + + if (*n == 0) { + return 0; + } + + eps = slamch_("Epsilon"); + sfmin = slamch_("Safe minimum"); + bignum = 1.f / sfmin; + + if (*job < 0) { + if (*tol <= 0.f) { + *tol = abs(a[1]); + if (*n > 1) { +/* Computing MAX */ + r__1 = *tol, r__2 = abs(a[2]), r__1 = f2cmax(r__1,r__2), r__2 = + abs(b[1]); + *tol = f2cmax(r__1,r__2); + } + i__1 = *n; + for (k = 3; k <= i__1; ++k) { +/* Computing MAX */ + r__4 = *tol, r__5 = (r__1 = a[k], abs(r__1)), r__4 = f2cmax(r__4, + r__5), r__5 = (r__2 = b[k - 1], abs(r__2)), r__4 = + f2cmax(r__4,r__5), r__5 = (r__3 = d__[k - 2], abs(r__3)); + *tol = f2cmax(r__4,r__5); +/* L10: */ + } + *tol *= eps; + if (*tol == 0.f) { + *tol = eps; + } + } + } + + if (abs(*job) == 1) { + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + if (in[k - 1] == 0) { + y[k] -= c__[k - 1] * y[k - 1]; + } else { + temp = y[k - 1]; + y[k - 1] = y[k]; + y[k] = temp - c__[k - 1] * y[k]; + } +/* L20: */ + } + if (*job == 1) { + for (k = *n; k >= 1; --k) { + if (k <= *n - 2) { + temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2]; + } else if (k == *n - 1) { + temp = y[k] - b[k] * y[k + 1]; + } else { + temp = y[k]; + } + ak = a[k]; + absak = abs(ak); + if (absak < 1.f) { + if (absak < sfmin) { + if (absak == 0.f || abs(temp) * sfmin > absak) { + *info = k; + return 0; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + *info = k; + return 0; + } + } + y[k] = temp / ak; +/* L30: */ + } + } else { + for (k = *n; k >= 1; --k) { + if (k <= *n - 2) { + temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2]; + } else if (k == *n - 1) { + temp = y[k] - b[k] * y[k + 1]; + } else { + temp = y[k]; + } + ak = a[k]; + pert = r_sign(tol, &ak); +L40: + absak = abs(ak); + if (absak < 1.f) { + if (absak < sfmin) { + if (absak == 0.f || abs(temp) * sfmin > absak) { + ak += pert; + pert *= 2; + goto L40; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + ak += pert; + pert *= 2; + goto L40; + } + } + y[k] = temp / ak; +/* L50: */ + } + } + } else { + +/* Come to here if JOB = 2 or -2 */ + + if (*job == 2) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (k >= 3) { + temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2]; + } else if (k == 2) { + temp = y[k] - b[k - 1] * y[k - 1]; + } else { + temp = y[k]; + } + ak = a[k]; + absak = abs(ak); + if (absak < 1.f) { + if (absak < sfmin) { + if (absak == 0.f || abs(temp) * sfmin > absak) { + *info = k; + return 0; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + *info = k; + return 0; + } + } + y[k] = temp / ak; +/* L60: */ + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (k >= 3) { + temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2]; + } else if (k == 2) { + temp = y[k] - b[k - 1] * y[k - 1]; + } else { + temp = y[k]; + } + ak = a[k]; + pert = r_sign(tol, &ak); +L70: + absak = abs(ak); + if (absak < 1.f) { + if (absak < sfmin) { + if (absak == 0.f || abs(temp) * sfmin > absak) { + ak += pert; + pert *= 2; + goto L70; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + ak += pert; + pert *= 2; + goto L70; + } + } + y[k] = temp / ak; +/* L80: */ + } + } + + for (k = *n; k >= 2; --k) { + if (in[k - 1] == 0) { + y[k - 1] -= c__[k - 1] * y[k]; + } else { + temp = y[k - 1]; + y[k - 1] = y[k]; + y[k] = temp - c__[k - 1] * y[k]; + } +/* L90: */ + } + } + +/* End of SLAGTS */ + + return 0; +} /* slagts_ */ + diff --git a/lapack-netlib/SRC/slagv2.c b/lapack-netlib/SRC/slagv2.c new file mode 100644 index 000000000..937c1ab83 --- /dev/null +++ b/lapack-netlib/SRC/slagv2.c @@ -0,0 +1,793 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where +B is upper triangular. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAGV2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, */ +/* CSR, SNR ) */ + +/* INTEGER LDA, LDB */ +/* REAL CSL, CSR, SNL, SNR */ +/* REAL A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), */ +/* $ B( LDB, * ), BETA( 2 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 */ +/* > matrix pencil (A,B) where B is upper triangular. This routine */ +/* > computes orthogonal (rotation) matrices given by CSL, SNL and CSR, */ +/* > SNR such that */ +/* > */ +/* > 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 */ +/* > types), then */ +/* > */ +/* > [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */ +/* > [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */ +/* > */ +/* > [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */ +/* > [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], */ +/* > */ +/* > 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, */ +/* > then */ +/* > */ +/* > [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */ +/* > [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */ +/* > */ +/* > [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */ +/* > [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] */ +/* > */ +/* > where b11 >= b22 > 0. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, 2) */ +/* > On entry, the 2 x 2 matrix A. */ +/* > On exit, A is overwritten by the ``A-part'' of the */ +/* > generalized Schur form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > THe leading dimension of the array A. LDA >= 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, 2) */ +/* > On entry, the upper triangular 2 x 2 matrix B. */ +/* > On exit, B is overwritten by the ``B-part'' of the */ +/* > generalized Schur form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > THe leading dimension of the array B. LDB >= 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is REAL array, dimension (2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is REAL array, dimension (2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (2) */ +/* > (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the */ +/* > pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may */ +/* > be zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSL */ +/* > \verbatim */ +/* > CSL is REAL */ +/* > The cosine of the left rotation matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNL */ +/* > \verbatim */ +/* > SNL is REAL */ +/* > The sine of the left rotation matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSR */ +/* > \verbatim */ +/* > CSR is REAL */ +/* > The cosine of the right rotation matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNR */ +/* > \verbatim */ +/* > SNR is REAL */ +/* > The sine of the right rotation matrix. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slagv2_(real *a, integer *lda, real *b, integer *ldb, + real *alphar, real *alphai, real *beta, real *csl, real *snl, real * + csr, real *snr) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset; + real r__1, r__2, r__3, r__4, r__5, r__6; + + /* Local variables */ + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *), slag2_(real *, integer *, real *, + integer *, real *, real *, real *, real *, real *, real *); + real r__, t, anorm, bnorm, h1, h2, h3, scale1, scale2; + extern /* Subroutine */ int slasv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *); + extern real slapy2_(real *, real *); + real ascale, bscale, wi, qq, rr; + extern real slamch_(char *); + real safmin; + extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real * + ); + real wr1, wr2, ulp; + + +/* -- 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; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + + /* Function Body */ + safmin = slamch_("S"); + ulp = slamch_("P"); + +/* Scale A */ + +/* Computing MAX */ + r__5 = (r__1 = a[a_dim1 + 1], abs(r__1)) + (r__2 = a[a_dim1 + 2], abs( + r__2)), r__6 = (r__3 = a[(a_dim1 << 1) + 1], abs(r__3)) + (r__4 = + a[(a_dim1 << 1) + 2], abs(r__4)), r__5 = f2cmax(r__5,r__6); + anorm = f2cmax(r__5,safmin); + ascale = 1.f / anorm; + a[a_dim1 + 1] = ascale * a[a_dim1 + 1]; + a[(a_dim1 << 1) + 1] = ascale * a[(a_dim1 << 1) + 1]; + a[a_dim1 + 2] = ascale * a[a_dim1 + 2]; + a[(a_dim1 << 1) + 2] = ascale * a[(a_dim1 << 1) + 2]; + +/* Scale B */ + +/* Computing MAX */ + r__4 = (r__3 = b[b_dim1 + 1], abs(r__3)), r__5 = (r__1 = b[(b_dim1 << 1) + + 1], abs(r__1)) + (r__2 = b[(b_dim1 << 1) + 2], abs(r__2)), r__4 + = f2cmax(r__4,r__5); + bnorm = f2cmax(r__4,safmin); + bscale = 1.f / bnorm; + b[b_dim1 + 1] = bscale * b[b_dim1 + 1]; + b[(b_dim1 << 1) + 1] = bscale * b[(b_dim1 << 1) + 1]; + b[(b_dim1 << 1) + 2] = bscale * b[(b_dim1 << 1) + 2]; + +/* Check if A can be deflated */ + + if ((r__1 = a[a_dim1 + 2], abs(r__1)) <= ulp) { + *csl = 1.f; + *snl = 0.f; + *csr = 1.f; + *snr = 0.f; + a[a_dim1 + 2] = 0.f; + b[b_dim1 + 2] = 0.f; + wi = 0.f; + +/* Check if B is singular */ + + } else if ((r__1 = b[b_dim1 + 1], abs(r__1)) <= ulp) { + slartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); + *csr = 1.f; + *snr = 0.f; + srot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + srot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + a[a_dim1 + 2] = 0.f; + b[b_dim1 + 1] = 0.f; + b[b_dim1 + 2] = 0.f; + wi = 0.f; + + } else if ((r__1 = b[(b_dim1 << 1) + 2], abs(r__1)) <= ulp) { + slartg_(&a[(a_dim1 << 1) + 2], &a[a_dim1 + 2], csr, snr, &t); + *snr = -(*snr); + srot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, csr, + snr); + srot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, csr, + snr); + *csl = 1.f; + *snl = 0.f; + a[a_dim1 + 2] = 0.f; + b[b_dim1 + 2] = 0.f; + b[(b_dim1 << 1) + 2] = 0.f; + wi = 0.f; + + } else { + +/* B is nonsingular, first compute the eigenvalues of (A,B) */ + + slag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, & + scale2, &wr1, &wr2, &wi); + + if (wi == 0.f) { + +/* two real eigenvalues, compute s*A-w*B */ + + h1 = scale1 * a[a_dim1 + 1] - wr1 * b[b_dim1 + 1]; + h2 = scale1 * a[(a_dim1 << 1) + 1] - wr1 * b[(b_dim1 << 1) + 1]; + h3 = scale1 * a[(a_dim1 << 1) + 2] - wr1 * b[(b_dim1 << 1) + 2]; + + rr = slapy2_(&h1, &h2); + r__1 = scale1 * a[a_dim1 + 2]; + qq = slapy2_(&r__1, &h3); + + if (rr > qq) { + +/* find right rotation matrix to zero 1,1 element of */ +/* (sA - wB) */ + + slartg_(&h2, &h1, csr, snr, &t); + + } else { + +/* find right rotation matrix to zero 2,1 element of */ +/* (sA - wB) */ + + r__1 = scale1 * a[a_dim1 + 2]; + slartg_(&h3, &r__1, csr, snr, &t); + + } + + *snr = -(*snr); + srot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, + csr, snr); + srot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, + csr, snr); + +/* compute inf norms of A and B */ + +/* Computing MAX */ + r__5 = (r__1 = a[a_dim1 + 1], abs(r__1)) + (r__2 = a[(a_dim1 << 1) + + 1], abs(r__2)), r__6 = (r__3 = a[a_dim1 + 2], abs(r__3) + ) + (r__4 = a[(a_dim1 << 1) + 2], abs(r__4)); + h1 = f2cmax(r__5,r__6); +/* Computing MAX */ + r__5 = (r__1 = b[b_dim1 + 1], abs(r__1)) + (r__2 = b[(b_dim1 << 1) + + 1], abs(r__2)), r__6 = (r__3 = b[b_dim1 + 2], abs(r__3) + ) + (r__4 = b[(b_dim1 << 1) + 2], abs(r__4)); + h2 = f2cmax(r__5,r__6); + + if (scale1 * h1 >= abs(wr1) * h2) { + +/* find left rotation matrix Q to zero out B(2,1) */ + + slartg_(&b[b_dim1 + 1], &b[b_dim1 + 2], csl, snl, &r__); + + } else { + +/* find left rotation matrix Q to zero out A(2,1) */ + + slartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); + + } + + srot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + srot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + + a[a_dim1 + 2] = 0.f; + b[b_dim1 + 2] = 0.f; + + } else { + +/* a pair of complex conjugate eigenvalues */ +/* first compute the SVD of the matrix B */ + + slasv2_(&b[b_dim1 + 1], &b[(b_dim1 << 1) + 1], &b[(b_dim1 << 1) + + 2], &r__, &t, snr, csr, snl, csl); + +/* Form (A,B) := Q(A,B)Z**T where Q is left rotation matrix and */ +/* Z is right rotation matrix computed from SLASV2 */ + + srot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + srot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + srot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, + csr, snr); + srot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, + csr, snr); + + b[b_dim1 + 2] = 0.f; + b[(b_dim1 << 1) + 1] = 0.f; + + } + + } + +/* Unscaling */ + + a[a_dim1 + 1] = anorm * a[a_dim1 + 1]; + a[a_dim1 + 2] = anorm * a[a_dim1 + 2]; + a[(a_dim1 << 1) + 1] = anorm * a[(a_dim1 << 1) + 1]; + a[(a_dim1 << 1) + 2] = anorm * a[(a_dim1 << 1) + 2]; + b[b_dim1 + 1] = bnorm * b[b_dim1 + 1]; + b[b_dim1 + 2] = bnorm * b[b_dim1 + 2]; + b[(b_dim1 << 1) + 1] = bnorm * b[(b_dim1 << 1) + 1]; + b[(b_dim1 << 1) + 2] = bnorm * b[(b_dim1 << 1) + 2]; + + if (wi == 0.f) { + alphar[1] = a[a_dim1 + 1]; + alphar[2] = a[(a_dim1 << 1) + 2]; + alphai[1] = 0.f; + alphai[2] = 0.f; + beta[1] = b[b_dim1 + 1]; + beta[2] = b[(b_dim1 << 1) + 2]; + } else { + alphar[1] = anorm * wr1 / scale1 / bnorm; + alphai[1] = anorm * wi / scale1 / bnorm; + alphar[2] = alphar[1]; + alphai[2] = -alphai[1]; + beta[1] = 1.f; + beta[2] = 1.f; + } + + return 0; + +/* End of SLAGV2 */ + +} /* slagv2_ */ + diff --git a/lapack-netlib/SRC/slahqr.c b/lapack-netlib/SRC/slahqr.c new file mode 100644 index 000000000..0d6fbb859 --- /dev/null +++ b/lapack-netlib/SRC/slahqr.c @@ -0,0 +1,1089 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using th +e double-shift/single-shift QR algorithm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAHQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, */ +/* ILOZ, IHIZ, Z, LDZ, INFO ) */ + +/* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N */ +/* LOGICAL WANTT, WANTZ */ +/* REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAHQR is an auxiliary routine called by SHSEQR to update the */ +/* > eigenvalues and Schur decomposition already computed by SHSEQR, by */ +/* > dealing with the Hessenberg submatrix in rows and columns ILO to */ +/* > IHI. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > = .TRUE. : the full Schur form T is required; */ +/* > = .FALSE.: only eigenvalues are required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > = .TRUE. : the matrix of Schur vectors Z is required; */ +/* > = .FALSE.: Schur vectors are not required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > It is assumed that H is already upper quasi-triangular in */ +/* > rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */ +/* > ILO = 1). SLAHQR works primarily with the Hessenberg */ +/* > submatrix in rows and columns ILO to IHI, but applies */ +/* > transformations to all of H if WANTT is .TRUE.. */ +/* > 1 <= ILO <= f2cmax(1,IHI); IHI <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO is zero and if WANTT is .TRUE., H is upper */ +/* > quasi-triangular in rows and columns ILO:IHI, with any */ +/* > 2-by-2 diagonal blocks in standard form. If INFO is zero */ +/* > and WANTT is .FALSE., the contents of H are unspecified on */ +/* > exit. The output state of H if INFO is nonzero is given */ +/* > below under the description of INFO. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR */ +/* > \verbatim */ +/* > WR is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is REAL array, dimension (N) */ +/* > The real and imaginary parts, respectively, of the computed */ +/* > eigenvalues ILO to IHI are stored in the corresponding */ +/* > elements of WR and WI. If two eigenvalues are computed as a */ +/* > complex conjugate pair, they are stored in consecutive */ +/* > elements of WR and WI, say the i-th and (i+1)th, with */ +/* > WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */ +/* > eigenvalues are stored in the same order as on the diagonal */ +/* > of the Schur form returned in H, with WR(i) = H(i,i), and, if */ +/* > H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */ +/* > WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. */ +/* > 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,N) */ +/* > If WANTZ is .TRUE., on entry Z must contain the current */ +/* > matrix Z of transformations accumulated by SHSEQR, and on */ +/* > exit Z has been updated; transformations are applied only to */ +/* > the submatrix Z(ILOZ:IHIZ,ILO:IHI). */ +/* > If WANTZ is .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: If INFO = i, SLAHQR failed to compute all the */ +/* > eigenvalues ILO to IHI in a total of 30 iterations */ +/* > per eigenvalue; elements i+1:ihi of WR and WI */ +/* > contain those eigenvalues which have been */ +/* > successfully computed. */ +/* > */ +/* > If INFO > 0 and WANTT is .FALSE., then on exit, */ +/* > the remaining unconverged eigenvalues are the */ +/* > eigenvalues of the upper Hessenberg matrix rows */ +/* > and columns ILO through INFO of the final, output */ +/* > value of H. */ +/* > */ +/* > If INFO > 0 and WANTT is .TRUE., then on exit */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > where U is an orthogonal matrix. The final */ +/* > value of H is upper Hessenberg and triangular in */ +/* > rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and WANTZ is .TRUE., then on exit */ +/* > (final value of Z) = (initial value of Z)*U */ +/* > where U is the orthogonal matrix in (*) */ +/* > (regardless of the value of WANTT.) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 02-96 Based on modifications by */ +/* > David Day, Sandia National Laboratory, USA */ +/* > */ +/* > 12-04 Further modifications by */ +/* > Ralph Byers, University of Kansas, USA */ +/* > This is a modified version of SLAHQR from LAPACK version 3.0. */ +/* > It is (1) more robust against overflow and underflow and */ +/* > (2) adopts the more conservative Ahues & Tisseur stopping */ +/* > criterion (LAWN 122, 1997). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n, + integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * + wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer * + info) +{ + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer i__, j, k, l, m; + real s, v[3]; + integer itmax, i1, i2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real t1, t2, t3, v2, v3, aa, ab, ba, bb; + extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *, real *); + real h11, h12, h21, h22, cs; + integer nh; + extern /* Subroutine */ int slabad_(real *, real *); + real sn; + integer nr; + real tr; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *); + real safmax, rtdisc, smlnum, det, h21s; + integer its; + real ulp, sum, tst, rt1i, rt2i, rt1r, rt2r; + + +/* -- 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 */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*ilo == *ihi) { + wr[*ilo] = h__[*ilo + *ilo * h_dim1]; + wi[*ilo] = 0.f; + return 0; + } + +/* ==== clear out the trash ==== */ + i__1 = *ihi - 3; + for (j = *ilo; j <= i__1; ++j) { + h__[j + 2 + j * h_dim1] = 0.f; + h__[j + 3 + j * h_dim1] = 0.f; +/* L10: */ + } + if (*ilo <= *ihi - 2) { + h__[*ihi + (*ihi - 2) * h_dim1] = 0.f; + } + + nh = *ihi - *ilo + 1; + nz = *ihiz - *iloz + 1; + +/* Set machine-dependent constants for the stopping criterion. */ + + safmin = slamch_("SAFE MINIMUM"); + safmax = 1.f / safmin; + slabad_(&safmin, &safmax); + ulp = slamch_("PRECISION"); + smlnum = safmin * ((real) nh / ulp); + +/* I1 and I2 are the indices of the first row and last column of H */ +/* to which transformations must be applied. If eigenvalues only are */ +/* being computed, I1 and I2 are set inside the main loop. */ + + if (*wantt) { + i1 = 1; + i2 = *n; + } + +/* ITMAX is the total number of QR iterations allowed. */ + + itmax = f2cmax(10,nh) * 30; + +/* The main loop begins here. I is the loop index and decreases from */ +/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */ +/* with the active submatrix in rows and columns L to I. */ +/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */ +/* H(L,L-1) is negligible so that the matrix splits. */ + + i__ = *ihi; +L20: + l = *ilo; + if (i__ < *ilo) { + goto L160; + } + +/* Perform QR iterations on rows and columns ILO to I until a */ +/* submatrix of order 1 or 2 splits off at the bottom because a */ +/* subdiagonal element has become negligible. */ + + i__1 = itmax; + for (its = 0; its <= i__1; ++its) { + +/* Look for a single small subdiagonal element. */ + + i__2 = l + 1; + for (k = i__; k >= i__2; --k) { + if ((r__1 = h__[k + (k - 1) * h_dim1], abs(r__1)) <= smlnum) { + goto L40; + } + tst = (r__1 = h__[k - 1 + (k - 1) * h_dim1], abs(r__1)) + (r__2 = + h__[k + k * h_dim1], abs(r__2)); + if (tst == 0.f) { + if (k - 2 >= *ilo) { + tst += (r__1 = h__[k - 1 + (k - 2) * h_dim1], abs(r__1)); + } + if (k + 1 <= *ihi) { + tst += (r__1 = h__[k + 1 + k * h_dim1], abs(r__1)); + } + } +/* ==== The following is a conservative small subdiagonal */ +/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */ +/* . 1997). It has better mathematical foundation and */ +/* . improves accuracy in some cases. ==== */ + if ((r__1 = h__[k + (k - 1) * h_dim1], abs(r__1)) <= ulp * tst) { +/* Computing MAX */ + r__3 = (r__1 = h__[k + (k - 1) * h_dim1], abs(r__1)), r__4 = ( + r__2 = h__[k - 1 + k * h_dim1], abs(r__2)); + ab = f2cmax(r__3,r__4); +/* Computing MIN */ + r__3 = (r__1 = h__[k + (k - 1) * h_dim1], abs(r__1)), r__4 = ( + r__2 = h__[k - 1 + k * h_dim1], abs(r__2)); + ba = f2cmin(r__3,r__4); +/* Computing MAX */ + r__3 = (r__1 = h__[k + k * h_dim1], abs(r__1)), r__4 = (r__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(r__2)); + aa = f2cmax(r__3,r__4); +/* Computing MIN */ + r__3 = (r__1 = h__[k + k * h_dim1], abs(r__1)), r__4 = (r__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(r__2)); + bb = f2cmin(r__3,r__4); + s = aa + ab; +/* Computing MAX */ + r__1 = smlnum, r__2 = ulp * (bb * (aa / s)); + if (ba * (ab / s) <= f2cmax(r__1,r__2)) { + goto L40; + } + } +/* L30: */ + } +L40: + l = k; + if (l > *ilo) { + +/* H(L,L-1) is negligible */ + + h__[l + (l - 1) * h_dim1] = 0.f; + } + +/* Exit from loop if a submatrix of order 1 or 2 has split off. */ + + if (l >= i__ - 1) { + goto L150; + } + +/* Now the active submatrix is in rows and columns L to I. If */ +/* eigenvalues only are being computed, only the active submatrix */ +/* need be transformed. */ + + if (! (*wantt)) { + i1 = l; + i2 = i__; + } + + if (its == 10) { + +/* Exceptional shift. */ + + s = (r__1 = h__[l + 1 + l * h_dim1], abs(r__1)) + (r__2 = h__[l + + 2 + (l + 1) * h_dim1], abs(r__2)); + h11 = s * .75f + h__[l + l * h_dim1]; + h12 = s * -.4375f; + h21 = s; + h22 = h11; + } else if (its == 20) { + +/* Exceptional shift. */ + + s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], abs(r__1)) + (r__2 = + h__[i__ - 1 + (i__ - 2) * h_dim1], abs(r__2)); + h11 = s * .75f + h__[i__ + i__ * h_dim1]; + h12 = s * -.4375f; + h21 = s; + h22 = h11; + } else { + +/* Prepare to use Francis' double shift */ +/* (i.e. 2nd degree generalized Rayleigh quotient) */ + + h11 = h__[i__ - 1 + (i__ - 1) * h_dim1]; + h21 = h__[i__ + (i__ - 1) * h_dim1]; + h12 = h__[i__ - 1 + i__ * h_dim1]; + h22 = h__[i__ + i__ * h_dim1]; + } + s = abs(h11) + abs(h12) + abs(h21) + abs(h22); + if (s == 0.f) { + rt1r = 0.f; + rt1i = 0.f; + rt2r = 0.f; + rt2i = 0.f; + } else { + h11 /= s; + h21 /= s; + h12 /= s; + h22 /= s; + tr = (h11 + h22) / 2.f; + det = (h11 - tr) * (h22 - tr) - h12 * h21; + rtdisc = sqrt((abs(det))); + if (det >= 0.f) { + +/* ==== complex conjugate shifts ==== */ + + rt1r = tr * s; + rt2r = rt1r; + rt1i = rtdisc * s; + rt2i = -rt1i; + } else { + +/* ==== real shifts (use only one of them) ==== */ + + rt1r = tr + rtdisc; + rt2r = tr - rtdisc; + if ((r__1 = rt1r - h22, abs(r__1)) <= (r__2 = rt2r - h22, abs( + r__2))) { + rt1r *= s; + rt2r = rt1r; + } else { + rt2r *= s; + rt1r = rt2r; + } + rt1i = 0.f; + rt2i = 0.f; + } + } + +/* Look for two consecutive small subdiagonal elements. */ + + i__2 = l; + for (m = i__ - 2; m >= i__2; --m) { +/* Determine the effect of starting the double-shift QR */ +/* iteration at row M, and see if this would make H(M,M-1) */ +/* negligible. (The following uses scaling to avoid */ +/* overflows and most underflows.) */ + + h21s = h__[m + 1 + m * h_dim1]; + s = (r__1 = h__[m + m * h_dim1] - rt2r, abs(r__1)) + abs(rt2i) + + abs(h21s); + h21s = h__[m + 1 + m * h_dim1] / s; + v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] - + rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i + / s); + v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1] + - rt1r - rt2r); + v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1]; + s = abs(v[0]) + abs(v[1]) + abs(v[2]); + v[0] /= s; + v[1] /= s; + v[2] /= s; + if (m == l) { + goto L60; + } + if ((r__1 = h__[m + (m - 1) * h_dim1], abs(r__1)) * (abs(v[1]) + + abs(v[2])) <= ulp * abs(v[0]) * ((r__2 = h__[m - 1 + (m - + 1) * h_dim1], abs(r__2)) + (r__3 = h__[m + m * h_dim1], + abs(r__3)) + (r__4 = h__[m + 1 + (m + 1) * h_dim1], abs( + r__4)))) { + goto L60; + } +/* L50: */ + } +L60: + +/* Double-shift QR step */ + + i__2 = i__ - 1; + for (k = m; k <= i__2; ++k) { + +/* The first iteration of this loop determines a reflection G */ +/* from the vector V and applies it from left and right to H, */ +/* thus creating a nonzero bulge below the subdiagonal. */ + +/* Each subsequent iteration determines a reflection G to */ +/* restore the Hessenberg form in the (K-1)th column, and thus */ +/* chases the bulge one step toward the bottom of the active */ +/* submatrix. NR is the order of G. */ + +/* Computing MIN */ + i__3 = 3, i__4 = i__ - k + 1; + nr = f2cmin(i__3,i__4); + if (k > m) { + scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); + } + slarfg_(&nr, v, &v[1], &c__1, &t1); + if (k > m) { + h__[k + (k - 1) * h_dim1] = v[0]; + h__[k + 1 + (k - 1) * h_dim1] = 0.f; + if (k < i__ - 1) { + h__[k + 2 + (k - 1) * h_dim1] = 0.f; + } + } else if (m > l) { +/* ==== Use the following instead of */ +/* . H( K, K-1 ) = -H( K, K-1 ) to */ +/* . avoid a bug when v(2) and v(3) */ +/* . underflow. ==== */ + h__[k + (k - 1) * h_dim1] *= 1.f - t1; + } + v2 = v[1]; + t2 = t1 * v2; + if (nr == 3) { + v3 = v[2]; + t3 = t1 * v3; + +/* Apply G from the left to transform the rows of the matrix */ +/* in columns K to I2. */ + + i__3 = i2; + for (j = k; j <= i__3; ++j) { + sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] + + v3 * h__[k + 2 + j * h_dim1]; + h__[k + j * h_dim1] -= sum * t1; + h__[k + 1 + j * h_dim1] -= sum * t2; + h__[k + 2 + j * h_dim1] -= sum * t3; +/* L70: */ + } + +/* Apply G from the right to transform the columns of the */ +/* matrix in rows I1 to f2cmin(K+3,I). */ + +/* Computing MIN */ + i__4 = k + 3; + i__3 = f2cmin(i__4,i__); + for (j = i1; j <= i__3; ++j) { + sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] + + v3 * h__[j + (k + 2) * h_dim1]; + h__[j + k * h_dim1] -= sum * t1; + h__[j + (k + 1) * h_dim1] -= sum * t2; + h__[j + (k + 2) * h_dim1] -= sum * t3; +/* L80: */ + } + + if (*wantz) { + +/* Accumulate transformations in the matrix Z */ + + i__3 = *ihiz; + for (j = *iloz; j <= i__3; ++j) { + sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * + z_dim1] + v3 * z__[j + (k + 2) * z_dim1]; + z__[j + k * z_dim1] -= sum * t1; + z__[j + (k + 1) * z_dim1] -= sum * t2; + z__[j + (k + 2) * z_dim1] -= sum * t3; +/* L90: */ + } + } + } else if (nr == 2) { + +/* Apply G from the left to transform the rows of the matrix */ +/* in columns K to I2. */ + + i__3 = i2; + for (j = k; j <= i__3; ++j) { + sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]; + h__[k + j * h_dim1] -= sum * t1; + h__[k + 1 + j * h_dim1] -= sum * t2; +/* L100: */ + } + +/* Apply G from the right to transform the columns of the */ +/* matrix in rows I1 to f2cmin(K+3,I). */ + + i__3 = i__; + for (j = i1; j <= i__3; ++j) { + sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] + ; + h__[j + k * h_dim1] -= sum * t1; + h__[j + (k + 1) * h_dim1] -= sum * t2; +/* L110: */ + } + + if (*wantz) { + +/* Accumulate transformations in the matrix Z */ + + i__3 = *ihiz; + for (j = *iloz; j <= i__3; ++j) { + sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * + z_dim1]; + z__[j + k * z_dim1] -= sum * t1; + z__[j + (k + 1) * z_dim1] -= sum * t2; +/* L120: */ + } + } + } +/* L130: */ + } + +/* L140: */ + } + +/* Failure to converge in remaining number of iterations */ + + *info = i__; + return 0; + +L150: + + if (l == i__) { + +/* H(I,I-1) is negligible: one eigenvalue has converged. */ + + wr[i__] = h__[i__ + i__ * h_dim1]; + wi[i__] = 0.f; + } else if (l == i__ - 1) { + +/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */ + +/* Transform the 2-by-2 submatrix to standard Schur form, */ +/* and compute and store the eigenvalues. */ + + slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * + h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * + h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, + &sn); + + if (*wantt) { + +/* Apply the transformation to the rest of H. */ + + if (i2 > i__) { + i__1 = i2 - i__; + srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[ + i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn); + } + i__1 = i__ - i1 - 1; + srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ * + h_dim1], &c__1, &cs, &sn); + } + if (*wantz) { + +/* Apply the transformation to Z. */ + + srot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz + + i__ * z_dim1], &c__1, &cs, &sn); + } + } + +/* return to start of the main loop with new value of I. */ + + i__ = l - 1; + goto L20; + +L160: + return 0; + +/* End of SLAHQR */ + +} /* slahqr_ */ + diff --git a/lapack-netlib/SRC/slahr2.c b/lapack-netlib/SRC/slahr2.c new file mode 100644 index 000000000..f91a31777 --- /dev/null +++ b/lapack-netlib/SRC/slahr2.c @@ -0,0 +1,761 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that +elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to +apply the transformation to the unreduced part */ +/* of A. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAHR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */ + +/* INTEGER K, LDA, LDT, LDY, N, NB */ +/* REAL A( LDA, * ), T( LDT, NB ), TAU( NB ), */ +/* $ Y( LDY, NB ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) */ +/* > matrix A so that elements below the k-th subdiagonal are zero. The */ +/* > reduction is performed by an orthogonal similarity transformation */ +/* > Q**T * A * Q. The routine returns the matrices V and T which determine */ +/* > Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. */ +/* > */ +/* > This is an auxiliary routine called by SGEHRD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The offset for the reduction. Elements below the k-th */ +/* > subdiagonal in the first NB columns are reduced to zero. */ +/* > K < N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of columns to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N-K+1) */ +/* > On entry, the n-by-(n-k+1) general matrix A. */ +/* > On exit, the elements on and above the k-th subdiagonal in */ +/* > the first NB columns are overwritten with the corresponding */ +/* > elements of the reduced matrix; the elements below the k-th */ +/* > subdiagonal, with the array TAU, represent the matrix Q as a */ +/* > product of elementary reflectors. The other columns of A are */ +/* > unchanged. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,NB) */ +/* > The upper triangular matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension (LDY,NB) */ +/* > The n-by-nb matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= N. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of nb elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(nb). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */ +/* > A(i+k+1:n,i), and tau in TAU(i). */ +/* > */ +/* > The elements of the vectors v together form the (n-k+1)-by-nb matrix */ +/* > V which is needed, with T and Y, to apply the transformation to the */ +/* > unreduced part of the matrix, using an update of the form: */ +/* > A := (I - V*T*V**T) * (A - Y*V**T). */ +/* > */ +/* > The contents of A on exit are illustrated by the following example */ +/* > with n = 7, k = 3 and nb = 2: */ +/* > */ +/* > ( a a a a a ) */ +/* > ( a a a a a ) */ +/* > ( a a a a a ) */ +/* > ( h h a a a ) */ +/* > ( v1 h a a a ) */ +/* > ( v1 v2 a a a ) */ +/* > ( v1 v2 a a a ) */ +/* > */ +/* > where a denotes an element of the original matrix A, h denotes a */ +/* > modified element of the upper Hessenberg matrix H, and vi denotes an */ +/* > element of the vector defining H(i). */ +/* > */ +/* > This subroutine is a slight modification of LAPACK-3.0's DLAHRD */ +/* > incorporating improvements proposed by Quintana-Orti and Van de */ +/* > Gejin. Note that the entries of A(1:K,2:NB) differ from those */ +/* > returned by the original LAPACK-3.0's DLAHRD routine. (This */ +/* > subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > Gregorio Quintana-Orti and Robert van de Geijn, "Improving the */ +/* > performance of reduction to Hessenberg form," ACM Transactions on */ +/* > Mathematical Software, 32(2):180-194, June 2006. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slahr2_(integer *n, integer *k, integer *nb, real *a, + integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + real r__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *), + strmm_(char *, char *, char *, char *, integer *, integer *, real + *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, + integer *), strmv_(char *, char *, char *, integer *, real *, + integer *, real *, integer *); + real ei; + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *), slacpy_(char *, integer *, integer *, real *, integer *, + real *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + + /* Function Body */ + if (*n <= 1) { + return 0; + } + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ > 1) { + +/* Update A(K+1:N,I) */ + +/* Update I-th column of A - Y * V**T */ + + i__2 = *n - *k; + i__3 = i__ - 1; + sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], + ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 + + i__ * a_dim1], &c__1); + +/* Apply I - V * T**T * V**T to this column (call it b) from the */ +/* left, using the last column of T as workspace */ + +/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */ +/* ( V2 ) ( b2 ) */ + +/* where V1 is unit lower triangular */ + +/* w := V1**T * b1 */ + + i__2 = i__ - 1; + scopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + strmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1); + +/* w := w + V2**T * b2 */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * + t_dim1 + 1], &c__1); + +/* w := T**T * w */ + + i__2 = i__ - 1; + strmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, + &t[*nb * t_dim1 + 1], &c__1); + +/* b2 := b2 - V2*w */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + + i__ * a_dim1], &c__1); + +/* b1 := b1 - V1*w */ + + i__2 = i__ - 1; + strmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1] + , lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + saxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ + * a_dim1], &c__1); + + a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei; + } + +/* Generate the elementary reflector H(I) to annihilate */ +/* A(K+I+1:N,I) */ + + i__2 = *n - *k - i__ + 1; +/* Computing MIN */ + i__3 = *k + i__ + 1; + slarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[f2cmin(i__3,*n) + i__ * + a_dim1], &c__1, &tau[i__]); + ei = a[*k + i__ + i__ * a_dim1]; + a[*k + i__ + i__ * a_dim1] = 1.f; + +/* Compute Y(K+1:N,I) */ + + i__2 = *n - *k; + i__3 = *n - *k - i__ + 1; + sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) * + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[* + k + 1 + i__ * y_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, & + a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + + 1], &c__1); + i__2 = *n - *k; + i__3 = i__ - 1; + sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy, + &t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1], + &c__1); + i__2 = *n - *k; + sscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1); + +/* Compute T(1:I,I) */ + + i__2 = i__ - 1; + r__1 = -tau[i__]; + sscal_(&i__2, &r__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + strmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, + &t[i__ * t_dim1 + 1], &c__1) + ; + t[i__ + i__ * t_dim1] = tau[i__]; + +/* L10: */ + } + a[*k + *nb + *nb * a_dim1] = ei; + +/* Compute Y(1:K,1:NB) */ + + slacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy); + strmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1 + + a_dim1], lda, &y[y_offset], ldy); + if (*n > *k + *nb) { + i__1 = *n - *k - *nb; + sgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb + + 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5, + &y[y_offset], ldy); + } + strmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[ + t_offset], ldt, &y[y_offset], ldy); + + return 0; + +/* End of SLAHR2 */ + +} /* slahr2_ */ + diff --git a/lapack-netlib/SRC/slaic1.c b/lapack-netlib/SRC/slaic1.c new file mode 100644 index 000000000..ab1b2f66b --- /dev/null +++ b/lapack-netlib/SRC/slaic1.c @@ -0,0 +1,756 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAIC1 applies one step of incremental condition estimation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAIC1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) */ + +/* INTEGER J, JOB */ +/* REAL C, GAMMA, S, SEST, SESTPR */ +/* REAL W( J ), X( J ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAIC1 applies one step of incremental condition estimation in */ +/* > its simplest version: */ +/* > */ +/* > Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */ +/* > lower triangular matrix L, such that */ +/* > twonorm(L*x) = sest */ +/* > Then SLAIC1 computes sestpr, s, c such that */ +/* > the vector */ +/* > [ s*x ] */ +/* > xhat = [ c ] */ +/* > is an approximate singular vector of */ +/* > [ L 0 ] */ +/* > Lhat = [ w**T gamma ] */ +/* > in the sense that */ +/* > twonorm(Lhat*xhat) = sestpr. */ +/* > */ +/* > Depending on JOB, an estimate for the largest or smallest singular */ +/* > value is computed. */ +/* > */ +/* > Note that [s c]**T and sestpr**2 is an eigenpair of the system */ +/* > */ +/* > diag(sest*sest, 0) + [alpha gamma] * [ alpha ] */ +/* > [ gamma ] */ +/* > */ +/* > where alpha = x**T*w. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is INTEGER */ +/* > = 1: an estimate for the largest singular value is computed. */ +/* > = 2: an estimate for the smallest singular value is computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Length of X and W */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (J) */ +/* > The j-vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SEST */ +/* > \verbatim */ +/* > SEST is REAL */ +/* > Estimated singular value of j by j matrix L */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (J) */ +/* > The j-vector w. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GAMMA */ +/* > \verbatim */ +/* > GAMMA is REAL */ +/* > The diagonal element gamma. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SESTPR */ +/* > \verbatim */ +/* > SESTPR is REAL */ +/* > Estimated singular value of (j+1) by (j+1) matrix Lhat. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL */ +/* > Sine needed in forming xhat. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > Cosine needed in forming xhat. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaic1_(integer *job, integer *j, real *x, real *sest, + real *w, real *gamma, real *sestpr, real *s, real *c__) +{ + /* System generated locals */ + real r__1, r__2, r__3, r__4; + + /* Local variables */ + real sine; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real test, zeta1, zeta2, b, t, alpha, norma, s1, s2, absgam, absalp; + extern real slamch_(char *); + real cosine, absest, eps, 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 */ + --w; + --x; + + /* Function Body */ + eps = slamch_("Epsilon"); + alpha = sdot_(j, &x[1], &c__1, &w[1], &c__1); + + absalp = abs(alpha); + absgam = abs(*gamma); + absest = abs(*sest); + + if (*job == 1) { + +/* Estimating largest singular value */ + +/* special cases */ + + if (*sest == 0.f) { + s1 = f2cmax(absgam,absalp); + if (s1 == 0.f) { + *s = 0.f; + *c__ = 1.f; + *sestpr = 0.f; + } else { + *s = alpha / s1; + *c__ = *gamma / s1; + tmp = sqrt(*s * *s + *c__ * *c__); + *s /= tmp; + *c__ /= tmp; + *sestpr = s1 * tmp; + } + return 0; + } else if (absgam <= eps * absest) { + *s = 1.f; + *c__ = 0.f; + tmp = f2cmax(absest,absalp); + s1 = absest / tmp; + s2 = absalp / tmp; + *sestpr = tmp * sqrt(s1 * s1 + s2 * s2); + return 0; + } else if (absalp <= eps * absest) { + s1 = absgam; + s2 = absest; + if (s1 <= s2) { + *s = 1.f; + *c__ = 0.f; + *sestpr = s2; + } else { + *s = 0.f; + *c__ = 1.f; + *sestpr = s1; + } + return 0; + } else if (absest <= eps * absalp || absest <= eps * absgam) { + s1 = absgam; + s2 = absalp; + if (s1 <= s2) { + tmp = s1 / s2; + *s = sqrt(tmp * tmp + 1.f); + *sestpr = s2 * *s; + *c__ = *gamma / s2 / *s; + *s = r_sign(&c_b5, &alpha) / *s; + } else { + tmp = s2 / s1; + *c__ = sqrt(tmp * tmp + 1.f); + *sestpr = s1 * *c__; + *s = alpha / s1 / *c__; + *c__ = r_sign(&c_b5, gamma) / *c__; + } + return 0; + } else { + +/* normal case */ + + zeta1 = alpha / absest; + zeta2 = *gamma / absest; + + b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f; + *c__ = zeta1 * zeta1; + if (b > 0.f) { + t = *c__ / (b + sqrt(b * b + *c__)); + } else { + t = sqrt(b * b + *c__) - b; + } + + sine = -zeta1 / t; + cosine = -zeta2 / (t + 1.f); + tmp = sqrt(sine * sine + cosine * cosine); + *s = sine / tmp; + *c__ = cosine / tmp; + *sestpr = sqrt(t + 1.f) * absest; + return 0; + } + + } else if (*job == 2) { + +/* Estimating smallest singular value */ + +/* special cases */ + + if (*sest == 0.f) { + *sestpr = 0.f; + if (f2cmax(absgam,absalp) == 0.f) { + sine = 1.f; + cosine = 0.f; + } else { + sine = -(*gamma); + cosine = alpha; + } +/* Computing MAX */ + r__1 = abs(sine), r__2 = abs(cosine); + s1 = f2cmax(r__1,r__2); + *s = sine / s1; + *c__ = cosine / s1; + tmp = sqrt(*s * *s + *c__ * *c__); + *s /= tmp; + *c__ /= tmp; + return 0; + } else if (absgam <= eps * absest) { + *s = 0.f; + *c__ = 1.f; + *sestpr = absgam; + return 0; + } else if (absalp <= eps * absest) { + s1 = absgam; + s2 = absest; + if (s1 <= s2) { + *s = 0.f; + *c__ = 1.f; + *sestpr = s1; + } else { + *s = 1.f; + *c__ = 0.f; + *sestpr = s2; + } + return 0; + } else if (absest <= eps * absalp || absest <= eps * absgam) { + s1 = absgam; + s2 = absalp; + if (s1 <= s2) { + tmp = s1 / s2; + *c__ = sqrt(tmp * tmp + 1.f); + *sestpr = absest * (tmp / *c__); + *s = -(*gamma / s2) / *c__; + *c__ = r_sign(&c_b5, &alpha) / *c__; + } else { + tmp = s2 / s1; + *s = sqrt(tmp * tmp + 1.f); + *sestpr = absest / *s; + *c__ = alpha / s1 / *s; + *s = -r_sign(&c_b5, gamma) / *s; + } + return 0; + } else { + +/* normal case */ + + zeta1 = alpha / absest; + zeta2 = *gamma / absest; + +/* Computing MAX */ + r__3 = zeta1 * zeta1 + 1.f + (r__1 = zeta1 * zeta2, abs(r__1)), + r__4 = (r__2 = zeta1 * zeta2, abs(r__2)) + zeta2 * zeta2; + norma = f2cmax(r__3,r__4); + +/* See if root is closer to zero or to ONE */ + + test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f; + if (test >= 0.f) { + +/* root is close to zero, compute directly */ + + b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f; + *c__ = zeta2 * zeta2; + t = *c__ / (b + sqrt((r__1 = b * b - *c__, abs(r__1)))); + sine = zeta1 / (1.f - t); + cosine = -zeta2 / t; + *sestpr = sqrt(t + eps * 4.f * eps * norma) * absest; + } else { + +/* root is closer to ONE, shift by that amount */ + + b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f; + *c__ = zeta1 * zeta1; + if (b >= 0.f) { + t = -(*c__) / (b + sqrt(b * b + *c__)); + } else { + t = b - sqrt(b * b + *c__); + } + sine = -zeta1 / t; + cosine = -zeta2 / (t + 1.f); + *sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest; + } + tmp = sqrt(sine * sine + cosine * cosine); + *s = sine / tmp; + *c__ = cosine / tmp; + return 0; + + } + } + return 0; + +/* End of SLAIC1 */ + +} /* slaic1_ */ + diff --git a/lapack-netlib/SRC/slaisnan.c b/lapack-netlib/SRC/slaisnan.c new file mode 100644 index 000000000..c5e70dcf4 --- /dev/null +++ b/lapack-netlib/SRC/slaisnan.c @@ -0,0 +1,481 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAISNAN tests input for NaN by comparing two arguments for inequality. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAISNAN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 ) */ + +/* REAL SIN1, SIN2 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is not for general use. It exists solely to avoid */ +/* > over-optimization in SISNAN. */ +/* > */ +/* > SLAISNAN checks for NaNs by comparing its two arguments for */ +/* > inequality. NaN is the only floating-point value where NaN != NaN */ +/* > returns .TRUE. To check for NaNs, pass the same variable as both */ +/* > arguments. */ +/* > */ +/* > A compiler must assume that the two arguments are */ +/* > not the same variable, and the test will not be optimized away. */ +/* > Interprocedural or whole-program optimization may delete this */ +/* > test. The ISNAN functions will be replaced by the correct */ +/* > Fortran 03 intrinsic once the intrinsic is widely available. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIN1 */ +/* > \verbatim */ +/* > SIN1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIN2 */ +/* > \verbatim */ +/* > SIN2 is REAL */ +/* > Two numbers to compare for inequality. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +logical slaisnan_(real *sin1, real *sin2) +{ + /* System generated locals */ + logical ret_val; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + ret_val = *sin1 != *sin2; + return ret_val; +} /* slaisnan_ */ + diff --git a/lapack-netlib/SRC/slaln2.c b/lapack-netlib/SRC/slaln2.c new file mode 100644 index 000000000..6feefea4f --- /dev/null +++ b/lapack-netlib/SRC/slaln2.c @@ -0,0 +1,1032 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLALN2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, */ +/* LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) */ + +/* LOGICAL LTRANS */ +/* INTEGER INFO, LDA, LDB, LDX, NA, NW */ +/* REAL CA, D1, D2, SCALE, SMIN, WI, WR, XNORM */ +/* REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALN2 solves a system of the form (ca A - w D ) X = s B */ +/* > or (ca A**T - w D) X = s B with possible scaling ("s") and */ +/* > perturbation of A. (A**T means A-transpose.) */ +/* > */ +/* > A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA */ +/* > real diagonal matrix, w is a real or complex value, and X and B are */ +/* > NA x 1 matrices -- real if w is real, complex if w is complex. NA */ +/* > may be 1 or 2. */ +/* > */ +/* > If w is complex, X and B are represented as NA x 2 matrices, */ +/* > the first column of each being the real part and the second */ +/* > being the imaginary part. */ +/* > */ +/* > "s" is a scaling factor (<= 1), computed by SLALN2, which is */ +/* > so chosen that X can be computed without overflow. X is further */ +/* > scaled if necessary to assure that norm(ca A - w D)*norm(X) is less */ +/* > than overflow. */ +/* > */ +/* > If both singular values of (ca A - w D) are less than SMIN, */ +/* > SMIN*identity will be used instead of (ca A - w D). If only one */ +/* > singular value is less than SMIN, one element of (ca A - w D) will be */ +/* > perturbed enough to make the smallest singular value roughly SMIN. */ +/* > If both singular values are at least SMIN, (ca A - w D) will not be */ +/* > perturbed. In any case, the perturbation will be at most some small */ +/* > multiple of f2cmax( SMIN, ulp*norm(ca A - w D) ). The singular values */ +/* > are computed by infinity-norm approximations, and thus will only be */ +/* > correct to a factor of 2 or so. */ +/* > */ +/* > Note: all input quantities are assumed to be smaller than overflow */ +/* > by a reasonable factor. (See BIGNUM.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] LTRANS */ +/* > \verbatim */ +/* > LTRANS is LOGICAL */ +/* > =.TRUE.: A-transpose will be used. */ +/* > =.FALSE.: A will be used (not transposed.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NA */ +/* > \verbatim */ +/* > NA is INTEGER */ +/* > The size of the matrix A. It may (only) be 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NW */ +/* > \verbatim */ +/* > NW is INTEGER */ +/* > 1 if "w" is real, 2 if "w" is complex. It may only be 1 */ +/* > or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMIN */ +/* > \verbatim */ +/* > SMIN is REAL */ +/* > The desired lower bound on the singular values of A. This */ +/* > should be a safe distance away from underflow or overflow, */ +/* > say, between (underflow/machine precision) and (machine */ +/* > precision * overflow ). (See BIGNUM and ULP.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CA */ +/* > \verbatim */ +/* > CA is REAL */ +/* > The coefficient c, which A is multiplied by. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,NA) */ +/* > The NA x NA matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. It must be at least NA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D1 */ +/* > \verbatim */ +/* > D1 is REAL */ +/* > The 1,1 element in the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D2 */ +/* > \verbatim */ +/* > D2 is REAL */ +/* > The 2,2 element in the diagonal matrix D. Not used if NA=1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NW) */ +/* > The NA x NW matrix B (right-hand side). If NW=2 ("w" is */ +/* > complex), column 1 contains the real part of B and column 2 */ +/* > contains the imaginary part. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. It must be at least NA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WR */ +/* > \verbatim */ +/* > WR is REAL */ +/* > The real part of the scalar "w". */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WI */ +/* > \verbatim */ +/* > WI is REAL */ +/* > The imaginary part of the scalar "w". Not used if NW=1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NW) */ +/* > The NA x NW matrix X (unknowns), as computed by SLALN2. */ +/* > If NW=2 ("w" is complex), on exit, column 1 will contain */ +/* > the real part of X and column 2 will contain the imaginary */ +/* > part. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of X. It must be at least NA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scale factor that B must be multiplied by to insure */ +/* > that overflow does not occur when computing X. Thus, */ +/* > (ca A - w D) X will be SCALE*B, not B (ignoring */ +/* > perturbations of A.) It will be at most 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] XNORM */ +/* > \verbatim */ +/* > XNORM is REAL */ +/* > The infinity-norm of X, when X is regarded as an NA x NW */ +/* > real matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > An error flag. It will be set to zero if no error occurs, */ +/* > a negative number if an argument is in error, or a positive */ +/* > number if ca A - w D had to be perturbed. */ +/* > The possible values are: */ +/* > = 0: No error occurred, and (ca A - w D) did not have to be */ +/* > perturbed. */ +/* > = 1: (ca A - w D) had to be perturbed to make its smallest */ +/* > (or only) singular value greater than SMIN. */ +/* > NOTE: In the interests of speed, this routine does not */ +/* > check the inputs for errors. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaln2_(logical *ltrans, integer *na, integer *nw, real * + smin, real *ca, real *a, integer *lda, real *d1, real *d2, real *b, + integer *ldb, real *wr, real *wi, real *x, integer *ldx, real *scale, + real *xnorm, integer *info) +{ + /* Initialized data */ + + static logical cswap[4] = { FALSE_,FALSE_,TRUE_,TRUE_ }; + static logical rswap[4] = { FALSE_,TRUE_,FALSE_,TRUE_ }; + static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2, + 4,3,2,1 }; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset; + real r__1, r__2, r__3, r__4, r__5, r__6; + static real equiv_0[4], equiv_1[4]; + + /* Local variables */ + real bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s; + integer j; + real u22abs; + integer icmax; + real bnorm, cnorm, smini; +#define ci (equiv_0) +#define cr (equiv_1) + extern real slamch_(char *); + real bignum; + extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real * + , real *); + real bi1, bi2, br1, br2, smlnum, xi1, xi2, xr1, xr2, ci21, ci22, cr21, + cr22, li21, csi, ui11, lr21, ui12, ui22; +#define civ (equiv_0) + real csr, ur11, ur12, ur22; +#define crv (equiv_1) + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + + /* Function Body */ + +/* Compute BIGNUM */ + + smlnum = 2.f * slamch_("Safe minimum"); + bignum = 1.f / smlnum; + smini = f2cmax(*smin,smlnum); + +/* Don't check for input errors */ + + *info = 0; + +/* Standard Initializations */ + + *scale = 1.f; + + if (*na == 1) { + +/* 1 x 1 (i.e., scalar) system C X = B */ + + if (*nw == 1) { + +/* Real 1x1 system. */ + +/* C = ca A - w D */ + + csr = *ca * a[a_dim1 + 1] - *wr * *d1; + cnorm = abs(csr); + +/* If | C | < SMINI, use C = SMINI */ + + if (cnorm < smini) { + csr = smini; + cnorm = smini; + *info = 1; + } + +/* Check scaling for X = B / C */ + + bnorm = (r__1 = b[b_dim1 + 1], abs(r__1)); + if (cnorm < 1.f && bnorm > 1.f) { + if (bnorm > bignum * cnorm) { + *scale = 1.f / bnorm; + } + } + +/* Compute X */ + + x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr; + *xnorm = (r__1 = x[x_dim1 + 1], abs(r__1)); + } else { + +/* Complex 1x1 system (w is complex) */ + +/* C = ca A - w D */ + + csr = *ca * a[a_dim1 + 1] - *wr * *d1; + csi = -(*wi) * *d1; + cnorm = abs(csr) + abs(csi); + +/* If | C | < SMINI, use C = SMINI */ + + if (cnorm < smini) { + csr = smini; + csi = 0.f; + cnorm = smini; + *info = 1; + } + +/* Check scaling for X = B / C */ + + bnorm = (r__1 = b[b_dim1 + 1], abs(r__1)) + (r__2 = b[(b_dim1 << + 1) + 1], abs(r__2)); + if (cnorm < 1.f && bnorm > 1.f) { + if (bnorm > bignum * cnorm) { + *scale = 1.f / bnorm; + } + } + +/* Compute X */ + + r__1 = *scale * b[b_dim1 + 1]; + r__2 = *scale * b[(b_dim1 << 1) + 1]; + sladiv_(&r__1, &r__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1) + + 1]); + *xnorm = (r__1 = x[x_dim1 + 1], abs(r__1)) + (r__2 = x[(x_dim1 << + 1) + 1], abs(r__2)); + } + + } else { + +/* 2x2 System */ + +/* Compute the real part of C = ca A - w D (or ca A**T - w D ) */ + + cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1; + cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2; + if (*ltrans) { + cr[2] = *ca * a[a_dim1 + 2]; + cr[1] = *ca * a[(a_dim1 << 1) + 1]; + } else { + cr[1] = *ca * a[a_dim1 + 2]; + cr[2] = *ca * a[(a_dim1 << 1) + 1]; + } + + if (*nw == 1) { + +/* Real 2x2 system (w is real) */ + +/* Find the largest element in C */ + + cmax = 0.f; + icmax = 0; + + for (j = 1; j <= 4; ++j) { + if ((r__1 = crv[j - 1], abs(r__1)) > cmax) { + cmax = (r__1 = crv[j - 1], abs(r__1)); + icmax = j; + } +/* L10: */ + } + +/* If norm(C) < SMINI, use SMINI*identity. */ + + if (cmax < smini) { +/* Computing MAX */ + r__3 = (r__1 = b[b_dim1 + 1], abs(r__1)), r__4 = (r__2 = b[ + b_dim1 + 2], abs(r__2)); + bnorm = f2cmax(r__3,r__4); + if (smini < 1.f && bnorm > 1.f) { + if (bnorm > bignum * smini) { + *scale = 1.f / bnorm; + } + } + temp = *scale / smini; + x[x_dim1 + 1] = temp * b[b_dim1 + 1]; + x[x_dim1 + 2] = temp * b[b_dim1 + 2]; + *xnorm = temp * bnorm; + *info = 1; + return 0; + } + +/* Gaussian elimination with complete pivoting. */ + + ur11 = crv[icmax - 1]; + cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; + ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; + cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; + ur11r = 1.f / ur11; + lr21 = ur11r * cr21; + ur22 = cr22 - ur12 * lr21; + +/* If smaller pivot < SMINI, use SMINI */ + + if (abs(ur22) < smini) { + ur22 = smini; + *info = 1; + } + if (rswap[icmax - 1]) { + br1 = b[b_dim1 + 2]; + br2 = b[b_dim1 + 1]; + } else { + br1 = b[b_dim1 + 1]; + br2 = b[b_dim1 + 2]; + } + br2 -= lr21 * br1; +/* Computing MAX */ + r__2 = (r__1 = br1 * (ur22 * ur11r), abs(r__1)), r__3 = abs(br2); + bbnd = f2cmax(r__2,r__3); + if (bbnd > 1.f && abs(ur22) < 1.f) { + if (bbnd >= bignum * abs(ur22)) { + *scale = 1.f / bbnd; + } + } + + xr2 = br2 * *scale / ur22; + xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12); + if (cswap[icmax - 1]) { + x[x_dim1 + 1] = xr2; + x[x_dim1 + 2] = xr1; + } else { + x[x_dim1 + 1] = xr1; + x[x_dim1 + 2] = xr2; + } +/* Computing MAX */ + r__1 = abs(xr1), r__2 = abs(xr2); + *xnorm = f2cmax(r__1,r__2); + +/* Further scaling if norm(A) norm(X) > overflow */ + + if (*xnorm > 1.f && cmax > 1.f) { + if (*xnorm > bignum / cmax) { + temp = cmax / bignum; + x[x_dim1 + 1] = temp * x[x_dim1 + 1]; + x[x_dim1 + 2] = temp * x[x_dim1 + 2]; + *xnorm = temp * *xnorm; + *scale = temp * *scale; + } + } + } else { + +/* Complex 2x2 system (w is complex) */ + +/* Find the largest element in C */ + + ci[0] = -(*wi) * *d1; + ci[1] = 0.f; + ci[2] = 0.f; + ci[3] = -(*wi) * *d2; + cmax = 0.f; + icmax = 0; + + for (j = 1; j <= 4; ++j) { + if ((r__1 = crv[j - 1], abs(r__1)) + (r__2 = civ[j - 1], abs( + r__2)) > cmax) { + cmax = (r__1 = crv[j - 1], abs(r__1)) + (r__2 = civ[j - 1] + , abs(r__2)); + icmax = j; + } +/* L20: */ + } + +/* If norm(C) < SMINI, use SMINI*identity. */ + + if (cmax < smini) { +/* Computing MAX */ + r__5 = (r__1 = b[b_dim1 + 1], abs(r__1)) + (r__2 = b[(b_dim1 + << 1) + 1], abs(r__2)), r__6 = (r__3 = b[b_dim1 + 2], + abs(r__3)) + (r__4 = b[(b_dim1 << 1) + 2], abs(r__4)); + bnorm = f2cmax(r__5,r__6); + if (smini < 1.f && bnorm > 1.f) { + if (bnorm > bignum * smini) { + *scale = 1.f / bnorm; + } + } + temp = *scale / smini; + x[x_dim1 + 1] = temp * b[b_dim1 + 1]; + x[x_dim1 + 2] = temp * b[b_dim1 + 2]; + x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1]; + x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2]; + *xnorm = temp * bnorm; + *info = 1; + return 0; + } + +/* Gaussian elimination with complete pivoting. */ + + ur11 = crv[icmax - 1]; + ui11 = civ[icmax - 1]; + cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; + ci21 = civ[ipivot[(icmax << 2) - 3] - 1]; + ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; + ui12 = civ[ipivot[(icmax << 2) - 2] - 1]; + cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; + ci22 = civ[ipivot[(icmax << 2) - 1] - 1]; + if (icmax == 1 || icmax == 4) { + +/* Code when off-diagonals of pivoted C are real */ + + if (abs(ur11) > abs(ui11)) { + temp = ui11 / ur11; +/* Computing 2nd power */ + r__1 = temp; + ur11r = 1.f / (ur11 * (r__1 * r__1 + 1.f)); + ui11r = -temp * ur11r; + } else { + temp = ur11 / ui11; +/* Computing 2nd power */ + r__1 = temp; + ui11r = -1.f / (ui11 * (r__1 * r__1 + 1.f)); + ur11r = -temp * ui11r; + } + lr21 = cr21 * ur11r; + li21 = cr21 * ui11r; + ur12s = ur12 * ur11r; + ui12s = ur12 * ui11r; + ur22 = cr22 - ur12 * lr21; + ui22 = ci22 - ur12 * li21; + } else { + +/* Code when diagonals of pivoted C are real */ + + ur11r = 1.f / ur11; + ui11r = 0.f; + lr21 = cr21 * ur11r; + li21 = ci21 * ur11r; + ur12s = ur12 * ur11r; + ui12s = ui12 * ur11r; + ur22 = cr22 - ur12 * lr21 + ui12 * li21; + ui22 = -ur12 * li21 - ui12 * lr21; + } + u22abs = abs(ur22) + abs(ui22); + +/* If smaller pivot < SMINI, use SMINI */ + + if (u22abs < smini) { + ur22 = smini; + ui22 = 0.f; + *info = 1; + } + if (rswap[icmax - 1]) { + br2 = b[b_dim1 + 1]; + br1 = b[b_dim1 + 2]; + bi2 = b[(b_dim1 << 1) + 1]; + bi1 = b[(b_dim1 << 1) + 2]; + } else { + br1 = b[b_dim1 + 1]; + br2 = b[b_dim1 + 2]; + bi1 = b[(b_dim1 << 1) + 1]; + bi2 = b[(b_dim1 << 1) + 2]; + } + br2 = br2 - lr21 * br1 + li21 * bi1; + bi2 = bi2 - li21 * br1 - lr21 * bi1; +/* Computing MAX */ + r__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r)) + ), r__2 = abs(br2) + abs(bi2); + bbnd = f2cmax(r__1,r__2); + if (bbnd > 1.f && u22abs < 1.f) { + if (bbnd >= bignum * u22abs) { + *scale = 1.f / bbnd; + br1 = *scale * br1; + bi1 = *scale * bi1; + br2 = *scale * br2; + bi2 = *scale * bi2; + } + } + + sladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2); + xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2; + xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2; + if (cswap[icmax - 1]) { + x[x_dim1 + 1] = xr2; + x[x_dim1 + 2] = xr1; + x[(x_dim1 << 1) + 1] = xi2; + x[(x_dim1 << 1) + 2] = xi1; + } else { + x[x_dim1 + 1] = xr1; + x[x_dim1 + 2] = xr2; + x[(x_dim1 << 1) + 1] = xi1; + x[(x_dim1 << 1) + 2] = xi2; + } +/* Computing MAX */ + r__1 = abs(xr1) + abs(xi1), r__2 = abs(xr2) + abs(xi2); + *xnorm = f2cmax(r__1,r__2); + +/* Further scaling if norm(A) norm(X) > overflow */ + + if (*xnorm > 1.f && cmax > 1.f) { + if (*xnorm > bignum / cmax) { + temp = cmax / bignum; + x[x_dim1 + 1] = temp * x[x_dim1 + 1]; + x[x_dim1 + 2] = temp * x[x_dim1 + 2]; + x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1]; + x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2]; + *xnorm = temp * *xnorm; + *scale = temp * *scale; + } + } + } + } + + return 0; + +/* End of SLALN2 */ + +} /* slaln2_ */ + +#undef crv +#undef civ +#undef cr +#undef ci + + diff --git a/lapack-netlib/SRC/slals0.c b/lapack-netlib/SRC/slals0.c new file mode 100644 index 000000000..a9e0d4dc5 --- /dev/null +++ b/lapack-netlib/SRC/slals0.c @@ -0,0 +1,952 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLALS0 applies back multiplying factors in solving the least squares problem using divide and c +onquer SVD approach. Used by sgelsd. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLALS0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, */ +/* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, */ +/* POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) */ + +/* INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, */ +/* $ LDGNUM, NL, NR, NRHS, SQRE */ +/* REAL C, S */ +/* INTEGER GIVCOL( LDGCOL, * ), PERM( * ) */ +/* REAL B( LDB, * ), BX( LDBX, * ), DIFL( * ), */ +/* $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), */ +/* $ POLES( LDGNUM, * ), WORK( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALS0 applies back the multiplying factors of either the left or the */ +/* > right singular vector matrix of a diagonal matrix appended by a row */ +/* > to the right hand side matrix B in solving the least squares problem */ +/* > using the divide-and-conquer SVD approach. */ +/* > */ +/* > For the left singular vector matrix, three types of orthogonal */ +/* > matrices are involved: */ +/* > */ +/* > (1L) Givens rotations: the number of such rotations is GIVPTR; the */ +/* > pairs of columns/rows they were applied to are stored in GIVCOL; */ +/* > and the C- and S-values of these rotations are stored in GIVNUM. */ +/* > */ +/* > (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */ +/* > row, and for J=2:N, PERM(J)-th row of B is to be moved to the */ +/* > J-th row. */ +/* > */ +/* > (3L) The left singular vector matrix of the remaining matrix. */ +/* > */ +/* > For the right singular vector matrix, four types of orthogonal */ +/* > matrices are involved: */ +/* > */ +/* > (1R) The right singular vector matrix of the remaining matrix. */ +/* > */ +/* > (2R) If SQRE = 1, one extra Givens rotation to generate the right */ +/* > null space. */ +/* > */ +/* > (3R) The inverse transformation of (2L). */ +/* > */ +/* > (4R) The inverse transformation of (1L). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether singular vectors are to be computed in */ +/* > factored form: */ +/* > = 0: Left singular vector matrix. */ +/* > = 1: Right singular vector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NL */ +/* > \verbatim */ +/* > NL is INTEGER */ +/* > The row dimension of the upper block. NL >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NR */ +/* > \verbatim */ +/* > NR is INTEGER */ +/* > The row dimension of the lower block. NR >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: the lower block is an NR-by-NR square matrix. */ +/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ +/* > */ +/* > The bidiagonal matrix has row dimension N = NL + NR + 1, */ +/* > and column dimension M = N + SQRE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of columns of B and BX. NRHS must be at least 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension ( LDB, NRHS ) */ +/* > On input, B contains the right hand sides of the least */ +/* > squares problem in rows 1 through M. On output, B contains */ +/* > the solution X in rows 1 through N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB must be at least */ +/* > f2cmax(1,MAX( M, N ) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BX */ +/* > \verbatim */ +/* > BX is REAL array, dimension ( LDBX, NRHS ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBX */ +/* > \verbatim */ +/* > LDBX is INTEGER */ +/* > The leading dimension of BX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension ( N ) */ +/* > The permutations (from deflation and sorting) applied */ +/* > to the two blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER */ +/* > The number of Givens rotations which took place in this */ +/* > subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) */ +/* > Each pair of numbers indicates a pair of rows/columns */ +/* > involved in a Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGCOL */ +/* > \verbatim */ +/* > LDGCOL is INTEGER */ +/* > The leading dimension of GIVCOL, must be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, dimension ( LDGNUM, 2 ) */ +/* > Each number indicates the C or S value used in the */ +/* > corresponding Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGNUM */ +/* > \verbatim */ +/* > LDGNUM is INTEGER */ +/* > The leading dimension of arrays DIFR, POLES and */ +/* > GIVNUM, must be at least K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] POLES */ +/* > \verbatim */ +/* > POLES is REAL array, dimension ( LDGNUM, 2 ) */ +/* > On entry, POLES(1:K, 1) contains the new singular */ +/* > values obtained from solving the secular equation, and */ +/* > POLES(1:K, 2) is an array containing the poles in the secular */ +/* > equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFL */ +/* > \verbatim */ +/* > DIFL is REAL array, dimension ( K ). */ +/* > On entry, DIFL(I) is the distance between I-th updated */ +/* > (undeflated) singular value and the I-th (undeflated) old */ +/* > singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFR */ +/* > \verbatim */ +/* > DIFR is REAL array, dimension ( LDGNUM, 2 ). */ +/* > On entry, DIFR(I, 1) contains the distances between I-th */ +/* > updated (undeflated) singular value and the I+1-th */ +/* > (undeflated) old singular value. And DIFR(I, 2) is the */ +/* > normalizing factor for the I-th right singular vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( K ) */ +/* > Contain the components of the deflation-adjusted updating row */ +/* > vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > Contains the dimension of the non-deflated matrix, */ +/* > This is the order of the related secular equation. 1 <= K <=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > C contains garbage if SQRE =0 and the C-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL */ +/* > S contains garbage if SQRE =0 and the S-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension ( K ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx, + integer *ldbx, integer *perm, integer *givptr, integer *givcol, + integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real * + difl, real *difr, real *z__, integer *k, real *c__, real *s, real * + work, integer *info) +{ + /* System generated locals */ + integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, + difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, + poles_offset, i__1, i__2; + real r__1; + + /* Local variables */ + real temp; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + extern real snrm2_(integer *, real *, integer *); + integer i__, j, m, n; + real diflj, difrj, dsigj; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *), scopy_( + integer *, real *, integer *, real *, integer *); + extern real slamc3_(real *, real *); + real dj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real dsigjp; + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, + real *, integer *); + integer nlp1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1 * 1; + bx -= bx_offset; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1 * 1; + givcol -= givcol_offset; + difr_dim1 = *ldgnum; + difr_offset = 1 + difr_dim1 * 1; + difr -= difr_offset; + poles_dim1 = *ldgnum; + poles_offset = 1 + poles_dim1 * 1; + poles -= poles_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1 * 1; + givnum -= givnum_offset; + --difl; + --z__; + --work; + + /* Function Body */ + *info = 0; + n = *nl + *nr + 1; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*nrhs < 1) { + *info = -5; + } else if (*ldb < n) { + *info = -7; + } else if (*ldbx < n) { + *info = -9; + } else if (*givptr < 0) { + *info = -11; + } else if (*ldgcol < n) { + *info = -13; + } else if (*ldgnum < n) { + *info = -15; +// } else if (*k < 1) { + } else if (*k < 0) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLALS0", &i__1, (ftnlen)6); + return 0; + } + + m = n + *sqre; + nlp1 = *nl + 1; + + if (*icompq == 0) { + +/* Apply back orthogonal transformations from the left. */ + +/* Step (1L): apply back the Givens rotations performed. */ + + i__1 = *givptr; + for (i__ = 1; i__ <= i__1; ++i__) { + srot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]); +/* L10: */ + } + +/* Step (2L): permute rows of B. */ + + scopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + scopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], + ldbx); +/* L20: */ + } + +/* Step (3L): apply the inverse of the left singular vector */ +/* matrix to BX. */ + + if (*k == 1) { + scopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); + if (z__[1] < 0.f) { + sscal_(nrhs, &c_b5, &b[b_offset], ldb); + } + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = poles[j + poles_dim1]; + dsigj = -poles[j + (poles_dim1 << 1)]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; + } + if (z__[j] == 0.f || poles[j + (poles_dim1 << 1)] == 0.f) { + work[j] = 0.f; + } else { + work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj / + (poles[j + (poles_dim1 << 1)] + dj); + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] == + 0.f) { + work[i__] = 0.f; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (slamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigj) - diflj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } +/* L30: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] == + 0.f) { + work[i__] = 0.f; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (slamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigjp) + difrj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } +/* L40: */ + } + work[1] = -1.f; + temp = snrm2_(k, &work[1], &c__1); + sgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & + c__1, &c_b13, &b[j + b_dim1], ldb); + slascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + + b_dim1], ldb, info); +/* L50: */ + } + } + +/* Move the deflated rows of BX to B also. */ + + if (*k < f2cmax(m,n)) { + i__1 = n - *k; + slacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 + + b_dim1], ldb); + } + } else { + +/* Apply back the right orthogonal transformations. */ + +/* Step (1R): apply back the new right singular vector matrix */ +/* to B. */ + + if (*k == 1) { + scopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dsigj = poles[j + (poles_dim1 << 1)]; + if (z__[j] == 0.f) { + work[j] = 0.f; + } else { + work[j] = -z__[j] / difl[j] / (dsigj + poles[j + + poles_dim1]) / difr[j + (difr_dim1 << 1)]; + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.f) { + work[i__] = 0.f; + } else { + r__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; + work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difr[ + i__ + difr_dim1]) / (dsigj + poles[i__ + + poles_dim1]) / difr[i__ + (difr_dim1 << 1)]; + } +/* L60: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.f) { + work[i__] = 0.f; + } else { + r__1 = -poles[i__ + (poles_dim1 << 1)]; + work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[ + i__]) / (dsigj + poles[i__ + poles_dim1]) / + difr[i__ + (difr_dim1 << 1)]; + } +/* L70: */ + } + sgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], & + c__1, &c_b13, &bx[j + bx_dim1], ldbx); +/* L80: */ + } + } + +/* Step (2R): if SQRE = 1, apply back the rotation that is */ +/* related to the right null space of the subproblem. */ + + if (*sqre == 1) { + scopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); + srot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, + s); + } + if (*k < f2cmax(m,n)) { + i__1 = n - *k; + slacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + + bx_dim1], ldbx); + } + +/* Step (3R): permute rows of B. */ + + scopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); + if (*sqre == 1) { + scopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); + } + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + scopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], + ldb); +/* L90: */ + } + +/* Step (4R): apply back the Givens rotations performed. */ + + for (i__ = *givptr; i__ >= 1; --i__) { + r__1 = -givnum[i__ + givnum_dim1]; + srot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &r__1); +/* L100: */ + } + } + + return 0; + +/* End of SLALS0 */ + +} /* slals0_ */ + diff --git a/lapack-netlib/SRC/slalsa.c b/lapack-netlib/SRC/slalsa.c new file mode 100644 index 000000000..9d6bd52da --- /dev/null +++ b/lapack-netlib/SRC/slalsa.c @@ -0,0 +1,946 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLALSA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, */ +/* LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, */ +/* GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, */ +/* IWORK, INFO ) */ + +/* INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, */ +/* $ SMLSIZ */ +/* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), */ +/* $ K( * ), PERM( LDGCOL, * ) */ +/* REAL B( LDB, * ), BX( LDBX, * ), C( * ), */ +/* $ DIFL( LDU, * ), DIFR( LDU, * ), */ +/* $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), */ +/* $ U( LDU, * ), VT( LDU, * ), WORK( * ), */ +/* $ Z( LDU, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALSA is an itermediate step in solving the least squares problem */ +/* > by computing the SVD of the coefficient matrix in compact form (The */ +/* > singular vectors are computed as products of simple orthorgonal */ +/* > matrices.). */ +/* > */ +/* > If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector */ +/* > matrix of an upper bidiagonal matrix to the right hand side; and if */ +/* > ICOMPQ = 1, SLALSA applies the right singular vector matrix to the */ +/* > right hand side. The singular vector matrices were generated in */ +/* > compact form by SLALSA. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether the left or the right singular vector */ +/* > matrix is involved. */ +/* > = 0: Left singular vector matrix */ +/* > = 1: Right singular vector matrix */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLSIZ */ +/* > \verbatim */ +/* > SMLSIZ is INTEGER */ +/* > The maximum size of the subproblems at the bottom of the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The row and column dimensions of the upper bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of columns of B and BX. NRHS must be at least 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension ( LDB, NRHS ) */ +/* > On input, B contains the right hand sides of the least */ +/* > squares problem in rows 1 through M. */ +/* > On output, B contains the solution X in rows 1 through N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B in the calling subprogram. */ +/* > LDB must be at least f2cmax(1,MAX( M, N ) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BX */ +/* > \verbatim */ +/* > BX is REAL array, dimension ( LDBX, NRHS ) */ +/* > On exit, the result of applying the left or right singular */ +/* > vector matrix to B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBX */ +/* > \verbatim */ +/* > LDBX is INTEGER */ +/* > The leading dimension of BX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] U */ +/* > \verbatim */ +/* > U is REAL array, dimension ( LDU, SMLSIZ ). */ +/* > On entry, U contains the left singular vector matrices of all */ +/* > subproblems at the bottom level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER, LDU = > N. */ +/* > The leading dimension of arrays U, VT, DIFL, DIFR, */ +/* > POLES, GIVNUM, and Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension ( LDU, SMLSIZ+1 ). */ +/* > On entry, VT**T contains the right singular vector matrices of */ +/* > all subproblems at the bottom level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER array, dimension ( N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFL */ +/* > \verbatim */ +/* > DIFL is REAL array, dimension ( LDU, NLVL ). */ +/* > where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFR */ +/* > \verbatim */ +/* > DIFR is REAL array, dimension ( LDU, 2 * NLVL ). */ +/* > On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */ +/* > distances between singular values on the I-th level and */ +/* > singular values on the (I -1)-th level, and DIFR(*, 2 * I) */ +/* > record the normalizing factors of the right singular vectors */ +/* > matrices of subproblems on I-th level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( LDU, NLVL ). */ +/* > On entry, Z(1, I) contains the components of the deflation- */ +/* > adjusted updating row vector for subproblems on the I-th */ +/* > level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] POLES */ +/* > \verbatim */ +/* > POLES is REAL array, dimension ( LDU, 2 * NLVL ). */ +/* > On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */ +/* > singular values involved in the secular equations on the I-th */ +/* > level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER array, dimension ( N ). */ +/* > On entry, GIVPTR( I ) records the number of Givens */ +/* > rotations performed on the I-th problem on the computation */ +/* > tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */ +/* > On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */ +/* > locations of Givens rotations performed on the I-th level on */ +/* > the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGCOL */ +/* > \verbatim */ +/* > LDGCOL is INTEGER, LDGCOL = > N. */ +/* > The leading dimension of arrays GIVCOL and PERM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension ( LDGCOL, NLVL ). */ +/* > On entry, PERM(*, I) records permutations done on the I-th */ +/* > level of the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, dimension ( LDU, 2 * NLVL ). */ +/* > On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */ +/* > values of Givens rotations performed on the I-th level on the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension ( N ). */ +/* > On entry, if the I-th subproblem is not square, */ +/* > C( I ) contains the C-value of a Givens rotation related to */ +/* > the right null space of the I-th subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension ( N ). */ +/* > On entry, if the I-th subproblem is not square, */ +/* > S( I ) contains the S-value of a Givens rotation related to */ +/* > the right null space of the I-th subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (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. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int slalsa_(integer *icompq, integer *smlsiz, integer *n, + integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, real * + u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real * + z__, real *poles, integer *givptr, integer *givcol, integer *ldgcol, + integer *perm, real *givnum, real *c__, real *s, real *work, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, + b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1, + difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, + u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, + i__2; + + /* Local variables */ + integer nlvl, sqre, i__, j, inode, ndiml; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer ndimr, i1; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), slals0_(integer *, integer *, integer *, integer *, + integer *, real *, integer *, real *, integer *, integer *, + integer *, integer *, integer *, real *, integer *, real *, real * + , real *, real *, integer *, real *, real *, real *, integer *); + integer ic, lf, nd, ll, nl, nr; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slasdt_( + integer *, integer *, integer *, integer *, integer *, integer *, + integer *); + integer im1, nlf, nrf, lvl, ndb1, nlp1, lvl2, nrp1; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1 * 1; + bx -= bx_offset; + givnum_dim1 = *ldu; + givnum_offset = 1 + givnum_dim1 * 1; + givnum -= givnum_offset; + poles_dim1 = *ldu; + poles_offset = 1 + poles_dim1 * 1; + poles -= poles_offset; + z_dim1 = *ldu; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + difr_dim1 = *ldu; + difr_offset = 1 + difr_dim1 * 1; + difr -= difr_offset; + difl_dim1 = *ldu; + difl_offset = 1 + difl_dim1 * 1; + difl -= difl_offset; + vt_dim1 = *ldu; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + --k; + --givptr; + perm_dim1 = *ldgcol; + perm_offset = 1 + perm_dim1 * 1; + perm -= perm_offset; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1 * 1; + givcol -= givcol_offset; + --c__; + --s; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*smlsiz < 3) { + *info = -2; + } else if (*n < *smlsiz) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < *n) { + *info = -6; + } else if (*ldbx < *n) { + *info = -8; + } else if (*ldu < *n) { + *info = -10; + } else if (*ldgcol < *n) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLALSA", &i__1, (ftnlen)6); + return 0; + } + +/* Book-keeping and setting up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + + slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); + +/* The following code applies back the left singular vector factors. */ +/* For applying back the right singular vector factors, go to 50. */ + + if (*icompq == 1) { + goto L50; + } + +/* The nodes on the bottom level of the tree were solved */ +/* by SLASDQ. The corresponding left and right singular vector */ +/* matrices are in explicit form. First apply back the left */ +/* singular vector matrices. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + +/* IC : center row of each node */ +/* NL : number of rows of left subproblem */ +/* NR : number of rows of right subproblem */ +/* NLF: starting row of the left subproblem */ +/* NRF: starting row of the right subproblem */ + + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + sgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf + + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); + sgemm_("T", "N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf + + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx); +/* L10: */ + } + +/* Next copy the rows of B that correspond to unchanged rows */ +/* in the bidiagonal matrix to BX. */ + + i__1 = nd; + for (i__ = 1; i__ <= i__1; ++i__) { + ic = iwork[inode + i__ - 1]; + scopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); +/* L20: */ + } + +/* Finally go through the left singular vector matrices of all */ +/* the other subproblems bottom-up on the tree. */ + + j = pow_ii(&c__2, &nlvl); + sqre = 0; + + for (lvl = nlvl; lvl >= 1; --lvl) { + lvl2 = (lvl << 1) - 1; + +/* find the first node LF and last node LL on */ +/* the current level LVL */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + --j; + slals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, & + b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &work[1], info); +/* L30: */ + } +/* L40: */ + } + goto L90; + +/* ICOMPQ = 1: applying back the right singular vector factors. */ + +L50: + +/* First now go through the right singular vector matrices of all */ +/* the tree nodes top-down. */ + + j = 0; + i__1 = nlvl; + for (lvl = 1; lvl <= i__1; ++lvl) { + lvl2 = (lvl << 1) - 1; + +/* Find the first node LF and last node LL on */ +/* the current level LVL. */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__2 = lvl - 1; + lf = pow_ii(&c__2, &i__2); + ll = (lf << 1) - 1; + } + i__2 = lf; + for (i__ = ll; i__ >= i__2; --i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqre = 0; + } else { + sqre = 1; + } + ++j; + slals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[ + nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &work[1], info); +/* L60: */ + } +/* L70: */ + } + +/* The nodes on the bottom level of the tree were solved */ +/* by SLASDQ. The corresponding right singular vector */ +/* matrices are in explicit form. Apply them back. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlp1 = nl + 1; + if (i__ == nd) { + nrp1 = nr; + } else { + nrp1 = nr + 1; + } + nlf = ic - nl; + nrf = ic + 1; + sgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & + b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); + sgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, & + b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx); +/* L80: */ + } + +L90: + + return 0; + +/* End of SLALSA */ + +} /* slalsa_ */ + diff --git a/lapack-netlib/SRC/slalsd.c b/lapack-netlib/SRC/slalsd.c new file mode 100644 index 000000000..837b2cbcd --- /dev/null +++ b/lapack-netlib/SRC/slalsd.c @@ -0,0 +1,969 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLALSD uses the singular value decomposition of A to solve the least squares problem. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLALSD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, */ +/* RANK, WORK, IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ */ +/* REAL RCOND */ +/* INTEGER IWORK( * ) */ +/* REAL B( LDB, * ), D( * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALSD uses the singular value decomposition of A to solve the least */ +/* > squares problem of finding X to minimize the Euclidean norm of each */ +/* > column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */ +/* > are N-by-NRHS. The solution X overwrites B. */ +/* > */ +/* > The singular values of A smaller than RCOND times the largest */ +/* > singular value are treated as zero in solving the least squares */ +/* > problem; in this case a minimum norm solution is returned. */ +/* > The actual singular values are returned in D in ascending order. */ +/* > */ +/* > This code makes very mild assumptions about floating point */ +/* > arithmetic. It will work on machines with a guard digit in */ +/* > add/subtract, or on those binary machines without guard digits */ +/* > which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */ +/* > It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': D and E define an upper bidiagonal matrix. */ +/* > = 'L': D and E define a lower bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLSIZ */ +/* > \verbatim */ +/* > SMLSIZ is INTEGER */ +/* > The maximum size of the subproblems at the bottom of the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the bidiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of columns of B. NRHS must be at least 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry D contains the main diagonal of the bidiagonal */ +/* > matrix. On exit, if INFO = 0, D contains its singular values. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > Contains the super-diagonal entries of the bidiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On input, B contains the right hand sides of the least */ +/* > squares problem. On output, B contains the solution X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B in the calling subprogram. */ +/* > LDB must be at least f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The singular values of A less than or equal to RCOND times */ +/* > the largest singular value are treated as zero in solving */ +/* > the least squares problem. If RCOND is negative, */ +/* > machine precision is used instead. */ +/* > For example, if diag(S)*X=B were the least squares problem, */ +/* > where diag(S) is a diagonal matrix of singular values, the */ +/* > solution would be X(i) = B(i) / S(i) if S(i) is greater than */ +/* > RCOND*f2cmax(S), and X(i) = 0 if S(i) is less than or equal to */ +/* > RCOND*f2cmax(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The number of singular values of A greater than RCOND times */ +/* > the largest singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension at least */ +/* > (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */ +/* > where NLVL = f2cmax(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension at least */ +/* > (3*N*NLVL + 11*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: The algorithm failed to compute a singular value 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 realOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer + *nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond, + integer *rank, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + real r__1; + + /* Local variables */ + integer difl, difr; + real rcnd; + integer perm, nsub, nlvl, sqre, bxst; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer c__, i__, j, k; + real r__; + integer s, u, z__; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer poles, sizei, nsize; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer nwork, icmpq1, icmpq2; + real cs; + integer bx; + real sn; + integer st; + extern real slamch_(char *); + extern /* Subroutine */ int slasda_(integer *, integer *, integer *, + integer *, real *, real *, real *, integer *, real *, integer *, + real *, real *, real *, real *, integer *, integer *, integer *, + integer *, real *, real *, real *, real *, integer *, integer *); + integer vt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slalsa_( + integer *, integer *, integer *, integer *, real *, integer *, + real *, integer *, real *, integer *, real *, integer *, real *, + real *, real *, real *, integer *, integer *, integer *, integer * + , real *, real *, real *, real *, integer *, integer *), slascl_( + char *, integer *, integer *, real *, real *, integer *, integer * + , real *, integer *, integer *); + integer givcol; + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer + *, integer *, integer *, real *, real *, real *, integer *, real * + , integer *, real *, integer *, real *, integer *), + slacpy_(char *, integer *, integer *, real *, integer *, real *, + integer *), slartg_(real *, real *, real *, real *, real * + ), slaset_(char *, integer *, integer *, real *, real *, real *, + integer *); + real orgnrm; + integer givnum; + extern real slanst_(char *, integer *, real *, real *); + extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); + integer givptr, nm1, smlszp, st1; + real eps; + integer iwk; + real tol; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < 1 || *ldb < *n) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLALSD", &i__1, (ftnlen)6); + return 0; + } + + eps = slamch_("Epsilon"); + +/* Set up the tolerance. */ + + if (*rcond <= 0.f || *rcond >= 1.f) { + rcnd = eps; + } else { + rcnd = *rcond; + } + + *rank = 0; + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } else if (*n == 1) { + if (d__[1] == 0.f) { + slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); + } else { + *rank = 1; + slascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ + b_offset], ldb, info); + d__[1] = abs(d__[1]); + } + return 0; + } + +/* Rotate the matrix if it is lower bidiagonal. */ + + if (*(unsigned char *)uplo == 'L') { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + slartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (*nrhs == 1) { + srot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & + c__1, &cs, &sn); + } else { + work[(i__ << 1) - 1] = cs; + work[i__ * 2] = sn; + } +/* L10: */ + } + if (*nrhs > 1) { + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - 1; + for (j = 1; j <= i__2; ++j) { + cs = work[(j << 1) - 1]; + sn = work[j * 2]; + srot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * + b_dim1], &c__1, &cs, &sn); +/* L20: */ + } +/* L30: */ + } + } + } + +/* Scale. */ + + nm1 = *n - 1; + orgnrm = slanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.f) { + slaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); + return 0; + } + + slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info); + slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, + info); + +/* If N is smaller than the minimum divide size SMLSIZ, then solve */ +/* the problem with another solver. */ + + if (*n <= *smlsiz) { + nwork = *n * *n + 1; + slaset_("A", n, n, &c_b6, &c_b11, &work[1], n); + slasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & + work[1], n, &b[b_offset], ldb, &work[nwork], info); + if (*info != 0) { + return 0; + } + tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], abs(r__1)); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= tol) { + slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb); + } else { + slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ + i__ + b_dim1], ldb, info); + ++(*rank); + } +/* L40: */ + } + sgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & + c_b6, &work[nwork], n); + slacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb); + +/* Unscale. */ + + slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, + info); + slasrt_("D", n, &d__[1], info); + slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], + ldb, info); + + return 0; + } + +/* Book-keeping and setting up some constants. */ + + nlvl = (integer) (log((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 1; + + smlszp = *smlsiz + 1; + + u = 1; + vt = *smlsiz * *n + 1; + difl = vt + smlszp * *n; + difr = difl + nlvl * *n; + z__ = difr + (nlvl * *n << 1); + c__ = z__ + nlvl * *n; + s = c__ + *n; + poles = s + *n; + givnum = poles + (nlvl << 1) * *n; + bx = givnum + (nlvl << 1) * *n; + nwork = bx + *n * *nrhs; + + sizei = *n + 1; + k = sizei + *n; + givptr = k + *n; + perm = givptr + *n; + givcol = perm + nlvl * *n; + iwk = givcol + (nlvl * *n << 1); + + st = 1; + sqre = 0; + icmpq1 = 1; + icmpq2 = 0; + nsub = 0; + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = d__[i__], abs(r__1)) < eps) { + d__[i__] = r_sign(&eps, &d__[i__]); + } +/* L50: */ + } + + i__1 = nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = e[i__], abs(r__1)) < eps || i__ == nm1) { + ++nsub; + iwork[nsub] = st; + +/* Subproblem found. First determine its size and then */ +/* apply divide and conquer on it. */ + + if (i__ < nm1) { + +/* A subproblem with E(I) small for I < NM1. */ + + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else if ((r__1 = e[i__], abs(r__1)) >= eps) { + +/* A subproblem with E(NM1) not too small but I = NM1. */ + + nsize = *n - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else { + +/* A subproblem with E(NM1) small. This implies an */ +/* 1-by-1 subproblem at D(N), which is not solved */ +/* explicitly. */ + + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + ++nsub; + iwork[nsub] = *n; + iwork[sizei + nsub - 1] = 1; + scopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); + } + st1 = st - 1; + if (nsize == 1) { + +/* This is a 1-by-1 subproblem and is not solved */ +/* explicitly. */ + + scopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); + } else if (nsize <= *smlsiz) { + +/* This is a small subproblem and is solved by SLASDQ. */ + + slaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], + n); + slasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ + st], &work[vt + st1], n, &work[nwork], n, &b[st + + b_dim1], ldb, &work[nwork], info); + if (*info != 0) { + return 0; + } + slacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + + st1], n); + } else { + +/* A large problem. Solve it using divide and conquer. */ + + slasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & + work[u + st1], n, &work[vt + st1], &iwork[k + st1], & + work[difl + st1], &work[difr + st1], &work[z__ + st1], + &work[poles + st1], &iwork[givptr + st1], &iwork[ + givcol + st1], n, &iwork[perm + st1], &work[givnum + + st1], &work[c__ + st1], &work[s + st1], &work[nwork], + &iwork[iwk], info); + if (*info != 0) { + return 0; + } + bxst = bx + st1; + slalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & + work[bxst], n, &work[u + st1], n, &work[vt + st1], & + iwork[k + st1], &work[difl + st1], &work[difr + st1], + &work[z__ + st1], &work[poles + st1], &iwork[givptr + + st1], &iwork[givcol + st1], n, &iwork[perm + st1], & + work[givnum + st1], &work[c__ + st1], &work[s + st1], + &work[nwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + } + st = i__ + 1; + } +/* L60: */ + } + +/* Apply the singular values and treat the tiny ones as zero. */ + + tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], abs(r__1)); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Some of the elements in D can be negative because 1-by-1 */ +/* subproblems were not solved explicitly. */ + + if ((r__1 = d__[i__], abs(r__1)) <= tol) { + slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n); + } else { + ++(*rank); + slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ + bx + i__ - 1], n, info); + } + d__[i__] = (r__1 = d__[i__], abs(r__1)); +/* L70: */ + } + +/* Now apply back the right singular vectors. */ + + icmpq2 = 1; + i__1 = nsub; + for (i__ = 1; i__ <= i__1; ++i__) { + st = iwork[i__]; + st1 = st - 1; + nsize = iwork[sizei + i__ - 1]; + bxst = bx + st1; + if (nsize == 1) { + scopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); + } else if (nsize <= *smlsiz) { + sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, + &work[bxst], n, &c_b6, &b[st + b_dim1], ldb); + } else { + slalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + + b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ + k + st1], &work[difl + st1], &work[difr + st1], &work[z__ + + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ + givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], + &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ + iwk], info); + if (*info != 0) { + return 0; + } + } +/* L80: */ + } + +/* Unscale and sort the singular values. */ + + slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info); + slasrt_("D", n, &d__[1], info); + slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, + info); + + return 0; + +/* End of SLALSD */ + +} /* slalsd_ */ + diff --git a/lapack-netlib/SRC/slamrg.c b/lapack-netlib/SRC/slamrg.c new file mode 100644 index 000000000..830ac79cf --- /dev/null +++ b/lapack-netlib/SRC/slamrg.c @@ -0,0 +1,566 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a +single set sorted in ascending order. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAMRG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX ) */ + +/* INTEGER N1, N2, STRD1, STRD2 */ +/* INTEGER INDEX( * ) */ +/* REAL A( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAMRG will create a permutation list which will merge the elements */ +/* > of A (which is composed of two independently sorted sets) into a */ +/* > single set which is sorted in ascending order. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N2 is INTEGER */ +/* > These arguments contain the respective lengths of the two */ +/* > sorted lists to be merged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (N1+N2) */ +/* > The first N1 elements of A contain a list of numbers which */ +/* > are sorted in either ascending or descending order. Likewise */ +/* > for the final N2 elements. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STRD1 */ +/* > \verbatim */ +/* > STRD1 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STRD2 */ +/* > \verbatim */ +/* > STRD2 is INTEGER */ +/* > These are the strides to be taken through the array A. */ +/* > Allowable strides are 1 and -1. They indicate whether a */ +/* > subset of A is sorted in ascending (STRDx = 1) or descending */ +/* > (STRDx = -1) order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDEX */ +/* > \verbatim */ +/* > INDEX is INTEGER array, dimension (N1+N2) */ +/* > On exit this array will contain a permutation such that */ +/* > if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be */ +/* > sorted in ascending order. */ +/* > \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 slamrg_(integer *n1, integer *n2, real *a, integer * + strd1, integer *strd2, integer *index) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ind1, ind2, n1sv, n2sv; + + +/* -- 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 */ + --index; + --a; + + /* Function Body */ + n1sv = *n1; + n2sv = *n2; + if (*strd1 > 0) { + ind1 = 1; + } else { + ind1 = *n1; + } + if (*strd2 > 0) { + ind2 = *n1 + 1; + } else { + ind2 = *n1 + *n2; + } + i__ = 1; +/* while ( (N1SV > 0) & (N2SV > 0) ) */ +L10: + if (n1sv > 0 && n2sv > 0) { + if (a[ind1] <= a[ind2]) { + index[i__] = ind1; + ++i__; + ind1 += *strd1; + --n1sv; + } else { + index[i__] = ind2; + ++i__; + ind2 += *strd2; + --n2sv; + } + goto L10; + } +/* end while */ + if (n1sv == 0) { + i__1 = n2sv; + for (n1sv = 1; n1sv <= i__1; ++n1sv) { + index[i__] = ind2; + ++i__; + ind2 += *strd2; +/* L20: */ + } + } else { +/* N2SV .EQ. 0 */ + i__1 = n1sv; + for (n2sv = 1; n2sv <= i__1; ++n2sv) { + index[i__] = ind1; + ++i__; + ind1 += *strd1; +/* L30: */ + } + } + + return 0; + +/* End of SLAMRG */ + +} /* slamrg_ */ + diff --git a/lapack-netlib/SRC/slamswlq.c b/lapack-netlib/SRC/slamswlq.c new file mode 100644 index 000000000..54a569fcc --- /dev/null +++ b/lapack-netlib/SRC/slamswlq.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 \b SLAMSWLQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, */ +/* $ LDT, C, LDC, WORK, LWORK, INFO ) */ + + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC */ +/* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), */ +/* $ T( LDT, * ) */ +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAMSWLQ overwrites the general real M-by-N matrix C with */ +/* > */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'T': Q**T * C C * Q**T */ +/* > where Q is a real orthogonal matrix defined as the product of blocked */ +/* > elementary reflectors computed by short wide LQ */ +/* > factorization (SLASWLQ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**T from the Left; */ +/* > = 'R': apply Q or Q**T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > M >= K >= 0; */ +/* > */ +/* > \endverbatim */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The row block size to be used in the blocked QR. */ +/* > M >= MB >= 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the blocked QR. */ +/* > NB > M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size to be used in the blocked QR. */ +/* > MB > M. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the blocked */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > SLASWLQ in the first k rows of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension */ +/* > ( M * Number of blocks(CEIL(N-K/NB-K)), */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See below */ +/* > for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) REAL array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If SIDE = 'L', LWORK >= f2cmax(1,NB) * MB; */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M) * MB. */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, */ +/* > representing Q as a product of other orthogonal matrices */ +/* > Q = Q(1) * Q(2) * . . . * Q(k) */ +/* > where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: */ +/* > Q(1) zeros out the upper diagonal entries of rows 1:NB of A */ +/* > Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A */ +/* > Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A */ +/* > . . . */ +/* > */ +/* > Q(1) is computed by GELQT, which represents Q(1) by Householder vectors */ +/* > stored under the diagonal of rows 1:MB of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,1:N). */ +/* > For more information see Further Details in GELQT. */ +/* > */ +/* > Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors */ +/* > stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). */ +/* > The last Q(k) may use fewer rows. */ +/* > For more information see Further Details in TPQRT. */ +/* > */ +/* > For more details of the overall algorithm, see the description of */ +/* > Sequential TSQR in Section 2.2 of [1]. */ +/* > */ +/* > [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations, */ +/* > J. Demmel, L. Grigori, M. Hoemmen, J. Langou, */ +/* > SIAM J. Sci. Comput, vol. 34, no. 1, 2012 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slamswlq_(char *side, char *trans, integer *m, integer * + n, integer *k, integer *mb, integer *nb, real *a, integer *lda, real * + t, integer *ldt, real *c__, integer *ldc, real *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ii, kk, lw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, lquery; + integer ctr; + extern /* Subroutine */ int sgemlqt_(char *, char *, integer *, integer *, + integer *, integer *, real *, integer *, real *, integer *, real + *, integer *, real *, integer *), stpmlqt_(char *, + char *, integer *, integer *, integer *, integer *, integer *, + real *, integer *, real *, integer *, real *, integer *, real *, + integer *, real *, integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + lquery = *lwork < 0; + notran = lsame_(trans, "N"); + tran = lsame_(trans, "T"); + left = lsame_(side, "L"); + right = lsame_(side, "R"); + if (left) { + lw = *n * *mb; + } else { + lw = *m * *mb; + } + + *info = 0; + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -9; + } else if (*ldt < f2cmax(1,*mb)) { + *info = -11; + } else if (*ldc < f2cmax(1,*m)) { + *info = -13; + } else if (*lwork < f2cmax(1,lw) && ! lquery) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAMSWLQ", &i__1, (ftnlen)8); + work[1] = (real) lw; + return 0; + } else if (lquery) { + work[1] = (real) lw; + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*k) == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = f2cmax(*m,*n); + if (*nb <= *k || *nb >= f2cmax(i__1,*k)) { + sgemlqt_(side, trans, m, n, k, mb, &a[a_offset], lda, &t[t_offset], + ldt, &c__[c_offset], ldc, &work[1], info); + return 0; + } + + if (left && tran) { + +/* Multiply Q to the last block of C */ + + kk = (*m - *k) % (*nb - *k); + ctr = (*m - *k) / (*nb - *k); + + if (kk > 0) { + ii = *m - kk + 1; + stpmlqt_("L", "T", &kk, n, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii + c_dim1], ldc, &work[1], info); + } else { + ii = *m + 1; + } + + i__1 = *nb + 1; + i__2 = -(*nb - *k); + for (i__ = ii - (*nb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (1:M,I:I+NB) */ + + --ctr; + i__3 = *nb - *k; + stpmlqt_("L", "T", &i__3, n, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + } + +/* Multiply Q to the first block of C (1:M,1:NB) */ + + sgemlqt_("L", "T", nb, n, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (left && notran) { + +/* Multiply Q to the first block of C */ + + kk = (*m - *k) % (*nb - *k); + ii = *m - kk + 1; + ctr = 1; + sgemlqt_("L", "N", nb, n, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + i__2 = ii - *nb + *k; + i__1 = *nb - *k; + for (i__ = *nb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (I:I+NB,1:N) */ + + i__3 = *nb - *k; + stpmlqt_("L", "N", &i__3, n, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *m) { + +/* Multiply Q to the last block of C */ + + stpmlqt_("L", "N", &kk, n, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii + c_dim1], ldc, &work[1], info); + + } + + } else if (right && notran) { + +/* Multiply Q to the last block of C */ + + kk = (*n - *k) % (*nb - *k); + ctr = (*n - *k) / (*nb - *k); + if (kk > 0) { + ii = *n - kk + 1; + stpmlqt_("R", "N", m, &kk, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii * c_dim1 + 1], ldc, &work[1], info); + } else { + ii = *n + 1; + } + + i__1 = *nb + 1; + i__2 = -(*nb - *k); + for (i__ = ii - (*nb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + --ctr; + i__3 = *nb - *k; + stpmlqt_("R", "N", m, &i__3, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + } + +/* Multiply Q to the first block of C (1:M,1:MB) */ + + sgemlqt_("R", "N", m, nb, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (right && tran) { + +/* Multiply Q to the first block of C */ + + kk = (*n - *k) % (*nb - *k); + ii = *n - kk + 1; + ctr = 1; + sgemlqt_("R", "T", m, nb, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + i__2 = ii - *nb + *k; + i__1 = *nb - *k; + for (i__ = *nb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + i__3 = *nb - *k; + stpmlqt_("R", "T", m, &i__3, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *n) { + +/* Multiply Q to the last block of C */ + + stpmlqt_("R", "T", m, &kk, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii * c_dim1 + 1], ldc, &work[1], info); + + } + + } + + work[1] = (real) lw; + return 0; + +/* End of SLAMSWLQ */ + +} /* slamswlq_ */ + diff --git a/lapack-netlib/SRC/slamtsqr.c b/lapack-netlib/SRC/slamtsqr.c new file mode 100644 index 000000000..74f0e7564 --- /dev/null +++ b/lapack-netlib/SRC/slamtsqr.c @@ -0,0 +1,843 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAMTSQR */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, */ +/* $ LDT, C, LDC, WORK, LWORK, INFO ) */ + + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC */ +/* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), */ +/* $ T( LDT, * ) */ +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAMTSQR overwrites the general real M-by-N matrix C with */ +/* > */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'T': Q**T * C C * Q**T */ +/* > where Q is a real orthogonal matrix defined as the product */ +/* > of blocked elementary reflectors computed by tall skinny */ +/* > QR factorization (DLATSQR) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**T from the Left; */ +/* > = 'R': apply Q or Q**T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > N >= K >= 0; */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size to be used in the blocked QR. */ +/* > MB > N. (must be the same as DLATSQR) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the blocked QR. */ +/* > N >= NB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > blockedelementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by DLATSQR in the first k columns of */ +/* > its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension */ +/* > ( N * Number of blocks(CEIL(M-K/MB-K)), */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See below */ +/* > for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) REAL array, dimension (MAX(1,LWORK)) */ +/* > */ +/* > \endverbatim */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > */ +/* > If SIDE = 'L', LWORK >= f2cmax(1,N)*NB; */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,MB)*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 */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, */ +/* > representing Q as a product of other orthogonal matrices */ +/* > Q = Q(1) * Q(2) * . . . * Q(k) */ +/* > where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: */ +/* > Q(1) zeros out the subdiagonal entries of rows 1:MB of A */ +/* > Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A */ +/* > Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A */ +/* > . . . */ +/* > */ +/* > Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors */ +/* > stored under the diagonal of rows 1:MB of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,1:N). */ +/* > For more information see Further Details in GEQRT. */ +/* > */ +/* > Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors */ +/* > stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). */ +/* > The last Q(k) may use fewer rows. */ +/* > For more information see Further Details in TPQRT. */ +/* > */ +/* > For more details of the overall algorithm, see the description of */ +/* > Sequential TSQR in Section 2.2 of [1]. */ +/* > */ +/* > [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations, */ +/* > J. Demmel, L. Grigori, M. Hoemmen, J. Langou, */ +/* > SIAM J. Sci. Comput, vol. 34, no. 1, 2012 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slamtsqr_(char *side, char *trans, integer *m, integer * + n, integer *k, integer *mb, integer *nb, real *a, integer *lda, real * + t, integer *ldt, real *c__, integer *ldc, real *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ii, kk, lw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, lquery; + integer ctr; + extern /* Subroutine */ int sgemqrt_(char *, char *, integer *, integer *, + integer *, integer *, real *, integer *, real *, integer *, real + *, integer *, real *, integer *), stpmqrt_(char *, + char *, integer *, integer *, integer *, integer *, integer *, + real *, integer *, real *, integer *, real *, integer *, real *, + integer *, real *, integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + lquery = *lwork < 0; + notran = lsame_(trans, "N"); + tran = lsame_(trans, "T"); + left = lsame_(side, "L"); + right = lsame_(side, "R"); + if (left) { + lw = *n * *nb; + } else { + lw = *mb * *nb; + } + + *info = 0; + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -9; + } else if (*ldt < f2cmax(1,*nb)) { + *info = -11; + } else if (*ldc < f2cmax(1,*m)) { + *info = -13; + } else if (*lwork < f2cmax(1,lw) && ! lquery) { + *info = -15; + } + +/* Determine the block size if it is tall skinny or short and wide */ + + if (*info == 0) { + work[1] = (real) lw; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAMTSQR", &i__1, (ftnlen)8); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*k) == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = f2cmax(*m,*n); + if (*mb <= *k || *mb >= f2cmax(i__1,*k)) { + sgemqrt_(side, trans, m, n, k, nb, &a[a_offset], lda, &t[t_offset], + ldt, &c__[c_offset], ldc, &work[1], info); + return 0; + } + + if (left && notran) { + +/* Multiply Q to the last block of C */ + + kk = (*m - *k) % (*mb - *k); + ctr = (*m - *k) / (*mb - *k); + if (kk > 0) { + ii = *m - kk + 1; + stpmqrt_("L", "N", &kk, n, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii + c_dim1], ldc, &work[1], info); + } else { + ii = *m + 1; + } + + i__1 = *mb + 1; + i__2 = -(*mb - *k); + for (i__ = ii - (*mb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (I:I+MB,1:N) */ + + --ctr; + i__3 = *mb - *k; + stpmqrt_("L", "N", &i__3, n, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + + } + +/* Multiply Q to the first block of C (1:MB,1:N) */ + + sgemqrt_("L", "N", mb, n, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (left && tran) { + +/* Multiply Q to the first block of C */ + + kk = (*m - *k) % (*mb - *k); + ii = *m - kk + 1; + ctr = 1; + sgemqrt_("L", "T", mb, n, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + i__2 = ii - *mb + *k; + i__1 = *mb - *k; + for (i__ = *mb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (I:I+MB,1:N) */ + + i__3 = *mb - *k; + stpmqrt_("L", "T", &i__3, n, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *m) { + +/* Multiply Q to the last block of C */ + + stpmqrt_("L", "T", &kk, n, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii + c_dim1], ldc, &work[1], info); + + } + + } else if (right && tran) { + +/* Multiply Q to the last block of C */ + + kk = (*n - *k) % (*mb - *k); + ctr = (*n - *k) / (*mb - *k); + if (kk > 0) { + ii = *n - kk + 1; + stpmqrt_("R", "T", m, &kk, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii * c_dim1 + 1], ldc, &work[1], info); + } else { + ii = *n + 1; + } + + i__1 = *mb + 1; + i__2 = -(*mb - *k); + for (i__ = ii - (*mb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + --ctr; + i__3 = *mb - *k; + stpmqrt_("R", "T", m, &i__3, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + + } + +/* Multiply Q to the first block of C (1:M,1:MB) */ + + sgemqrt_("R", "T", m, mb, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (right && notran) { + +/* Multiply Q to the first block of C */ + + kk = (*n - *k) % (*mb - *k); + ii = *n - kk + 1; + ctr = 1; + sgemqrt_("R", "N", m, mb, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + i__2 = ii - *mb + *k; + i__1 = *mb - *k; + for (i__ = *mb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + i__3 = *mb - *k; + stpmqrt_("R", "N", m, &i__3, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *n) { + +/* Multiply Q to the last block of C */ + + stpmqrt_("R", "N", m, &kk, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii * c_dim1 + 1], ldc, &work[1], info); + + } + + } + + work[1] = (real) lw; + return 0; + +/* End of SLAMTSQR */ + +} /* slamtsqr_ */ + diff --git a/lapack-netlib/SRC/slaneg.c b/lapack-netlib/SRC/slaneg.c new file mode 100644 index 000000000..76b774bc6 --- /dev/null +++ b/lapack-netlib/SRC/slaneg.c @@ -0,0 +1,641 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANEG computes the Sturm count. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANEG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R ) */ + +/* INTEGER N, R */ +/* REAL PIVMIN, SIGMA */ +/* REAL D( * ), LLD( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANEG computes the Sturm count, the number of negative pivots */ +/* > encountered while factoring tridiagonal T - sigma I = L D L^T. */ +/* > This implementation works directly on the factors without forming */ +/* > the tridiagonal matrix T. The Sturm count is also the number of */ +/* > eigenvalues of T less than sigma. */ +/* > */ +/* > This routine is called from SLARRB. */ +/* > */ +/* > The current routine does not use the PIVMIN parameter but rather */ +/* > requires IEEE-754 propagation of Infinities and NaNs. This */ +/* > routine also has no input range restrictions but does require */ +/* > default exception handling such that x/0 produces Inf when x is */ +/* > non-zero, and Inf/Inf produces NaN. For more information, see: */ +/* > */ +/* > Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in */ +/* > Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on */ +/* > Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 */ +/* > (Tech report version in LAWN 172 with the same title.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The N diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LLD */ +/* > \verbatim */ +/* > LLD is REAL array, dimension (N-1) */ +/* > The (N-1) elements L(i)*L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIGMA */ +/* > \verbatim */ +/* > SIGMA is REAL */ +/* > Shift amount in T - sigma I = L D L^T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot in the Sturm sequence. May be used */ +/* > when zero pivots are encountered on non-IEEE-754 */ +/* > architectures. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] R */ +/* > \verbatim */ +/* > R is INTEGER */ +/* > The twist index for the twisted factorization that is used */ +/* > for the negcount. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA \n */ +/* > Jason Riedy, University of California, Berkeley, USA \n */ +/* > */ +/* ===================================================================== */ +integer slaneg_(integer *n, real *d__, real *lld, real *sigma, real *pivmin, + integer *r__) +{ + /* System generated locals */ + integer ret_val, i__1, i__2, i__3, i__4; + + /* Local variables */ + real bsav; + integer j; + real p, gamma, t, dplus; + integer bj, negcnt; + logical sawnan; + extern logical sisnan_(real *); + real dminus, tmp; + integer neg1, neg2; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + +/* Some architectures propagate Infinities and NaNs very slowly, so */ +/* the code computes counts in BLKLEN chunks. Then a NaN can */ +/* propagate at most BLKLEN columns before being detected. This is */ +/* not a general tuning parameter; it needs only to be just large */ +/* enough that the overhead is tiny in common cases. */ + /* Parameter adjustments */ + --lld; + --d__; + + /* Function Body */ + negcnt = 0; +/* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T */ + t = -(*sigma); + i__1 = *r__ - 1; + for (bj = 1; bj <= i__1; bj += 128) { + neg1 = 0; + bsav = t; +/* Computing MIN */ + i__3 = bj + 127, i__4 = *r__ - 1; + i__2 = f2cmin(i__3,i__4); + for (j = bj; j <= i__2; ++j) { + dplus = d__[j] + t; + if (dplus < 0.f) { + ++neg1; + } + tmp = t / dplus; + t = tmp * lld[j] - *sigma; +/* L21: */ + } + sawnan = sisnan_(&t); +/* Run a slower version of the above loop if a NaN is detected. */ +/* A NaN should occur only with a zero pivot after an infinite */ +/* pivot. In that case, substituting 1 for T/DPLUS is the */ +/* correct limit. */ + if (sawnan) { + neg1 = 0; + t = bsav; +/* Computing MIN */ + i__3 = bj + 127, i__4 = *r__ - 1; + i__2 = f2cmin(i__3,i__4); + for (j = bj; j <= i__2; ++j) { + dplus = d__[j] + t; + if (dplus < 0.f) { + ++neg1; + } + tmp = t / dplus; + if (sisnan_(&tmp)) { + tmp = 1.f; + } + t = tmp * lld[j] - *sigma; +/* L22: */ + } + } + negcnt += neg1; +/* L210: */ + } + +/* II) lower part: L D L^T - SIGMA I = U- D- U-^T */ + p = d__[*n] - *sigma; + i__1 = *r__; + for (bj = *n - 1; bj >= i__1; bj += -128) { + neg2 = 0; + bsav = p; +/* Computing MAX */ + i__3 = bj - 127; + i__2 = f2cmax(i__3,*r__); + for (j = bj; j >= i__2; --j) { + dminus = lld[j] + p; + if (dminus < 0.f) { + ++neg2; + } + tmp = p / dminus; + p = tmp * d__[j] - *sigma; +/* L23: */ + } + sawnan = sisnan_(&p); +/* As above, run a slower version that substitutes 1 for Inf/Inf. */ + + if (sawnan) { + neg2 = 0; + p = bsav; +/* Computing MAX */ + i__3 = bj - 127; + i__2 = f2cmax(i__3,*r__); + for (j = bj; j >= i__2; --j) { + dminus = lld[j] + p; + if (dminus < 0.f) { + ++neg2; + } + tmp = p / dminus; + if (sisnan_(&tmp)) { + tmp = 1.f; + } + p = tmp * d__[j] - *sigma; +/* L24: */ + } + } + negcnt += neg2; +/* L230: */ + } + +/* III) Twist index */ +/* T was shifted by SIGMA initially. */ + gamma = t + *sigma + p; + if (gamma < 0.f) { + ++negcnt; + } + ret_val = negcnt; + return ret_val; +} /* slaneg_ */ + diff --git a/lapack-netlib/SRC/slangb.c b/lapack-netlib/SRC/slangb.c new file mode 100644 index 000000000..f4993b77c --- /dev/null +++ b/lapack-netlib/SRC/slangb.c @@ -0,0 +1,663 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of general band matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANGB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, */ +/* WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER KL, KU, LDAB, N */ +/* REAL AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANGB returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of an */ +/* > n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANGB */ +/* > \verbatim */ +/* > */ +/* > SLANGB = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANGB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANGB is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of sub-diagonals of the matrix A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of super-diagonals of the matrix A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ +/* > column of A is stored in the j-th column of the array AB as */ +/* > follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(n,j+kl). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBauxiliary */ + +/* ===================================================================== */ +real slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, + integer *ldab, real *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real ret_val, r__1; + + /* Local variables */ + real temp; + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j, k, l; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__3 = f2cmin(i__4,i__5); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + temp = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); + if (value < temp || sisnan_(&temp)) { + value = temp; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.f; +/* Computing MAX */ + i__3 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__2 = f2cmin(i__4,i__5); + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { + sum += (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); +/* L30: */ + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + k = *ku + 1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *n, i__6 = j + *kl; + i__4 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + work[i__] += (r__1 = ab[k + i__ + j * ab_dim1], abs(r__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.f; + ssq[1] = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; + l = f2cmax(i__4,i__2); + k = *ku + 1 - j + l; + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kl; + i__4 = f2cmin(i__2,i__3) - l + 1; + slassq_(&i__4, &ab[k + j * ab_dim1], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANGB */ + +} /* slangb_ */ + diff --git a/lapack-netlib/SRC/slange.c b/lapack-netlib/SRC/slange.c new file mode 100644 index 000000000..5c348e8e5 --- /dev/null +++ b/lapack-netlib/SRC/slange.c @@ -0,0 +1,634 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER LDA, M, N */ +/* REAL A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANGE returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > real matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANGE */ +/* > \verbatim */ +/* > */ +/* > SLANGE = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANGE as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. When M = 0, */ +/* > SLANGE is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. When N = 0, */ +/* > SLANGE is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(M,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGEauxiliary */ + +/* ===================================================================== */ +real slange_(char *norm, integer *m, integer *n, real *a, integer *lda, real * + work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real ret_val, r__1; + + /* Local variables */ + real temp; + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < temp || sisnan_(&temp)) { + value = temp; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.f; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L30: */ + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.f; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.f; + ssq[1] = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + slassq_(m, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANGE */ + +} /* slange_ */ + diff --git a/lapack-netlib/SRC/slangt.c b/lapack-netlib/SRC/slangt.c new file mode 100644 index 000000000..f3a88efa9 --- /dev/null +++ b/lapack-netlib/SRC/slangt.c @@ -0,0 +1,624 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of a general tridiagonal matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANGT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANGT( NORM, N, DL, D, DU ) */ + +/* CHARACTER NORM */ +/* INTEGER N */ +/* REAL D( * ), DL( * ), DU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANGT returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > real tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANGT */ +/* > \verbatim */ +/* > */ +/* > SLANGT = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANGT as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANGT is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is REAL array, dimension (N-1) */ +/* > The (n-1) sub-diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is REAL array, dimension (N-1) */ +/* > The (n-1) super-diagonal elements of A. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +real slangt_(char *norm, integer *n, real *dl, real *d__, real *du) +{ + /* System generated locals */ + integer i__1; + real ret_val, r__1, r__2, r__3, r__4; + + /* Local variables */ + real temp; + integer i__; + real scale; + extern logical lsame_(char *, char *); + real anorm; + extern logical sisnan_(real *); + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --du; + --d__; + --dl; + + /* Function Body */ + if (*n <= 0) { + anorm = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + anorm = (r__1 = d__[*n], abs(r__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + r__3 = (r__2 = dl[i__], abs(r__2)); + if (anorm < (r__1 = dl[i__], abs(r__1)) || sisnan_(&r__3)) { + anorm = (r__4 = dl[i__], abs(r__4)); + } + r__3 = (r__2 = d__[i__], abs(r__2)); + if (anorm < (r__1 = d__[i__], abs(r__1)) || sisnan_(&r__3)) { + anorm = (r__4 = d__[i__], abs(r__4)); + } + r__3 = (r__2 = du[i__], abs(r__2)); + if (anorm < (r__1 = du[i__], abs(r__1)) || sisnan_(&r__3)) { + anorm = (r__4 = du[i__], abs(r__4)); + } +/* L10: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + if (*n == 1) { + anorm = abs(d__[1]); + } else { + anorm = abs(d__[1]) + abs(dl[1]); + temp = (r__1 = d__[*n], abs(r__1)) + (r__2 = du[*n - 1], abs(r__2) + ); + if (anorm < temp || sisnan_(&temp)) { + anorm = temp; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + temp = (r__1 = d__[i__], abs(r__1)) + (r__2 = dl[i__], abs( + r__2)) + (r__3 = du[i__ - 1], abs(r__3)); + if (anorm < temp || sisnan_(&temp)) { + anorm = temp; + } +/* L20: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + if (*n == 1) { + anorm = abs(d__[1]); + } else { + anorm = abs(d__[1]) + abs(du[1]); + temp = (r__1 = d__[*n], abs(r__1)) + (r__2 = dl[*n - 1], abs(r__2) + ); + if (anorm < temp || sisnan_(&temp)) { + anorm = temp; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + temp = (r__1 = d__[i__], abs(r__1)) + (r__2 = du[i__], abs( + r__2)) + (r__3 = dl[i__ - 1], abs(r__3)); + if (anorm < temp || sisnan_(&temp)) { + anorm = temp; + } +/* L30: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.f; + sum = 1.f; + slassq_(n, &d__[1], &c__1, &scale, &sum); + if (*n > 1) { + i__1 = *n - 1; + slassq_(&i__1, &dl[1], &c__1, &scale, &sum); + i__1 = *n - 1; + slassq_(&i__1, &du[1], &c__1, &scale, &sum); + } + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of SLANGT */ + +} /* slangt_ */ + diff --git a/lapack-netlib/SRC/slanhs.c b/lapack-netlib/SRC/slanhs.c new file mode 100644 index 000000000..d3dfedf73 --- /dev/null +++ b/lapack-netlib/SRC/slanhs.c @@ -0,0 +1,635 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of an upper Hessenberg matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANHS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER LDA, N */ +/* REAL A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANHS returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > Hessenberg matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANHS */ +/* > \verbatim */ +/* > */ +/* > SLANHS = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANHS as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANHS is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The n by n upper Hessenberg matrix A; the part of A below the */ +/* > first sub-diagonal is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +real slanhs_(char *norm, integer *n, real *a, integer *lda, real *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + real ret_val, r__1; + + /* Local variables */ + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.f; +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L30: */ + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.f; + ssq[1] = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANHS */ + +} /* slanhs_ */ + diff --git a/lapack-netlib/SRC/slansb.c b/lapack-netlib/SRC/slansb.c new file mode 100644 index 000000000..eb5576159 --- /dev/null +++ b/lapack-netlib/SRC/slansb.c @@ -0,0 +1,714 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a symmetric band matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANSB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, */ +/* WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER K, LDAB, N */ +/* REAL AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANSB returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of an */ +/* > n by n symmetric band matrix A, with k super-diagonals. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANSB */ +/* > \verbatim */ +/* > */ +/* > SLANSB = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANSB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > band matrix A is supplied. */ +/* > = 'U': Upper triangular part is supplied */ +/* > = 'L': Lower triangular part is supplied */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANSB is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of super-diagonals or sub-diagonals of the */ +/* > band matrix A. K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The upper or lower triangle of the symmetric band matrix A, */ +/* > stored in the first K+1 rows of AB. The j-th column of A is */ +/* > stored in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for f2cmax(1,j-k)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= K+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +real slansb_(char *norm, char *uplo, integer *n, integer *k, real *ab, + integer *ldab, real *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + real ret_val, r__1; + + /* Local variables */ + real absa; + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j, l; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k + 1; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + sum = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *n + 1 - j, i__4 = *k + 1; + i__3 = f2cmin(i__2,i__4); + for (i__ = 1; i__ <= i__3; ++i__) { + sum = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.f; + l = *k + 1 - j; +/* Computing MAX */ + i__3 = 1, i__2 = j - *k; + i__4 = j - 1; + for (i__ = f2cmax(i__3,i__2); i__ <= i__4; ++i__) { + absa = (r__1 = ab[l + i__ + j * ab_dim1], abs(r__1)); + sum += absa; + work[i__] += absa; +/* L50: */ + } + work[j] = sum + (r__1 = ab[*k + 1 + j * ab_dim1], abs(r__1)); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (r__1 = ab[j * ab_dim1 + 1], abs(r__1)); + l = 1 - j; +/* Computing MIN */ + i__3 = *n, i__2 = j + *k; + i__4 = f2cmin(i__3,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + absa = (r__1 = ab[l + i__ + j * ab_dim1], abs(r__1)); + sum += absa; + work[i__] += absa; +/* L90: */ + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.f; + ssq[1] = 1.f; + +/* Sum off-diagonals */ + + if (*k > 0) { + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__3 = j - 1; + i__4 = f2cmin(i__3,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + slassq_(&i__4, &ab[f2cmax(i__2,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L110: */ + } + l = *k + 1; + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__3 = *n - j; + i__4 = f2cmin(i__3,*k); + slassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, colssq, & + colssq[1]); + scombssq_(ssq, colssq); +/* L120: */ + } + l = 1; + } + ssq[1] *= 2; + } else { + l = 1; + } + +/* Sum diagonal */ + + colssq[0] = 0.f; + colssq[1] = 1.f; + slassq_(n, &ab[l + ab_dim1], ldab, colssq, &colssq[1]); + scombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANSB */ + +} /* slansb_ */ + diff --git a/lapack-netlib/SRC/slansf.c b/lapack-netlib/SRC/slansf.c new file mode 100644 index 000000000..b589e5e31 --- /dev/null +++ b/lapack-netlib/SRC/slansf.c @@ -0,0 +1,1479 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANSF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANSF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) */ + +/* CHARACTER NORM, TRANSR, UPLO */ +/* INTEGER N */ +/* REAL A( 0: * ), WORK( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANSF returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > real symmetric matrix A in RFP format. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANSF */ +/* > \verbatim */ +/* > */ +/* > SLANSF = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANSF as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > Specifies whether the RFP format of A is normal or */ +/* > transposed format. */ +/* > = 'N': RFP format is Normal; */ +/* > = 'T': RFP format is Transpose. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the RFP matrix A came from */ +/* > an upper or lower triangular matrix as follows: */ +/* > = 'U': RFP A came from an upper triangular matrix; */ +/* > = 'L': RFP A came from a lower triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANSF is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension ( N*(N+1)/2 ); */ +/* > On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */ +/* > part of the symmetric matrix A stored in RFP format. See the */ +/* > "Notes" below for more details. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ + +/* ===================================================================== */ +real slansf_(char *norm, char *transr, char *uplo, integer *n, real *a, real * + work) +{ + /* System generated locals */ + integer i__1, i__2; + real ret_val, r__1; + + /* Local variables */ + real temp; + integer i__, j, k, l; + real s, scale; + extern logical lsame_(char *, char *); + real value; + integer n1; + real aa; + extern logical sisnan_(real *); + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + integer lda, ifm, noe, ilu; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + if (*n == 0) { + ret_val = 0.f; + return ret_val; + } else if (*n == 1) { + ret_val = abs(a[0]); + return ret_val; + } + +/* set noe = 1 if n is odd. if n is even set noe=0 */ + + noe = 1; + if (*n % 2 == 0) { + noe = 0; + } + +/* set ifm = 0 when form='T or 't' and 1 otherwise */ + + ifm = 1; + if (lsame_(transr, "T")) { + ifm = 0; + } + +/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */ + + ilu = 1; + if (lsame_(uplo, "U")) { + ilu = 0; + } + +/* set lda = (n+1)/2 when ifm = 0 */ +/* set lda = n when ifm = 1 and noe = 1 */ +/* set lda = n+1 when ifm = 1 and noe = 0 */ + + if (ifm == 1) { + if (noe == 1) { + lda = *n; + } else { +/* noe=0 */ + lda = *n + 1; + } + } else { +/* ifm=0 */ + lda = (*n + 1) / 2; + } + + if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + k = (*n + 1) / 2; + value = 0.f; + if (noe == 1) { +/* n is odd */ + if (ifm == 1) { +/* A is n by k */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = (r__1 = a[i__ + j * lda], abs(r__1)); + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } else { +/* xpose case; A is k by n */ + i__1 = *n - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = (r__1 = a[i__ + j * lda], abs(r__1)); + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } + } else { +/* n is even */ + if (ifm == 1) { +/* A is n+1 by k */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = (r__1 = a[i__ + j * lda], abs(r__1)); + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } else { +/* xpose case; A is k by n+1 */ + i__1 = *n; + for (j = 0; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = (r__1 = a[i__ + j * lda], abs(r__1)); + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + if (ifm == 1) { + k = *n / 2; + if (noe == 1) { +/* n is odd */ + if (ilu == 0) { + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + i__1 = k; + for (j = 0; j <= i__1; ++j) { + s = 0.f; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + if (i__ == k + k) { + goto L10; + } + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.f; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } +L10: + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu = 1 */ + ++k; +/* k=(n+1)/2 for n odd and ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + for (j = k - 1; j >= 0; --j) { + s = 0.f; + i__1 = j - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + if (j > 0) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + } + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.f; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } else { +/* n is even */ + if (ilu == 0) { + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.f; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.f; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu = 1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + for (j = k - 1; j >= 0; --j) { + s = 0.f; + i__1 = j - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.f; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } + } else { +/* ifm=0 */ + k = *n / 2; + if (noe == 1) { +/* n is odd */ + if (ilu == 0) { + n1 = k; +/* n/2 */ + ++k; +/* k is the row size and lda */ + i__1 = *n - 1; + for (i__ = n1; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.f; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,n1+i) */ + work[i__ + n1] += aa; + s += aa; + } + work[j] = s; + } +/* j=n1=k-1 is special */ + s = (r__1 = a[j * lda], abs(r__1)); +/* A(k-1,k-1) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(k-1,i+n1) */ + work[i__ + n1] += aa; + s += aa; + } + work[j] += s; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + s = 0.f; + i__2 = j - k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(i,j-k) */ + work[i__] += aa; + s += aa; + } +/* i=j-k */ + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j-k,j-k) */ + s += aa; + work[j - k] += s; + ++i__; + s = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,j) */ + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,l) */ + work[l] += aa; + s += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu=1 */ + ++k; +/* k=(n+1)/2 for n odd and ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { +/* process */ + s = 0.f; + i__2 = j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,i) */ + work[i__] += aa; + s += aa; + } + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* i=j so process of A(j,j) */ + s += aa; + work[j] = s; +/* is initialised here */ + ++i__; +/* i=j process A(j+k,j+k) */ + aa = (r__1 = a[i__ + j * lda], abs(r__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(l,k+j) */ + s += aa; + work[l] += aa; + } + work[k + j] += s; + } +/* j=k-1 is special :process col A(k-1,0:k-1) */ + s = 0.f; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] = s; +/* done with col j=k+1 */ + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { +/* process col j of A = A(j,0:k-1) */ + s = 0.f; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,i) */ + work[i__] += aa; + s += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } else { +/* n is even */ + if (ilu == 0) { + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.f; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,i+k) */ + work[i__ + k] += aa; + s += aa; + } + work[j] = s; + } +/* j=k */ + aa = (r__1 = a[j * lda], abs(r__1)); +/* A(k,k) */ + s = aa; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(k,k+i) */ + work[i__ + k] += aa; + s += aa; + } + work[j] += s; + i__1 = *n - 1; + for (j = k + 1; j <= i__1; ++j) { + s = 0.f; + i__2 = j - 2 - k; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(i,j-k-1) */ + work[i__] += aa; + s += aa; + } +/* i=j-1-k */ + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j-k-1,j-k-1) */ + s += aa; + work[j - k - 1] += s; + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,j) */ + s = aa; + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j,l) */ + work[l] += aa; + s += aa; + } + work[j] += s; + } +/* j=n */ + s = 0.f; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(i,k-1) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] += s; + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } +/* j=0 is special :process col A(k:n-1,k) */ + s = abs(a[0]); +/* A(k,k) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__], abs(r__1)); +/* A(k+i,k) */ + work[i__ + k] += aa; + s += aa; + } + work[k] += s; + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { +/* process */ + s = 0.f; + i__2 = j - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j-1,i) */ + work[i__] += aa; + s += aa; + } + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* i=j-1 so process of A(j-1,j-1) */ + s += aa; + work[j - 1] = s; +/* is initialised here */ + ++i__; +/* i=j process A(j+k,j+k) */ + aa = (r__1 = a[i__ + j * lda], abs(r__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(l,k+j) */ + s += aa; + work[l] += aa; + } + work[k + j] += s; + } +/* j=k is special :process col A(k,0:k-1) */ + s = 0.f; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] = s; +/* done with col j=k+1 */ + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { +/* process col j-1 of A = A(j-1,0:k-1) */ + s = 0.f; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (r__1 = a[i__ + j * lda], abs(r__1)); +/* A(j-1,i) */ + work[i__] += aa; + s += aa; + } + work[j - 1] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || sisnan_(&temp)) { + value = temp; + } + } + } + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + k = (*n + 1) / 2; + scale = 0.f; + s = 1.f; + if (noe == 1) { +/* n is odd */ + if (ifm == 1) { +/* A is normal */ + if (ilu == 0) { +/* A is upper */ + i__1 = k - 3; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 2; + slassq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale, + &s); +/* L at A(k,0) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j - 1; + slassq_(&i__2, &a[j * lda], &c__1, &scale, &s); +/* trap U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = k - 1; + i__2 = lda + 1; + slassq_(&i__1, &a[k], &i__2, &scale, &s); +/* tri L at A(k,0) */ + i__1 = lda + 1; + slassq_(&k, &a[k - 1], &i__1, &scale, &s); +/* tri U at A(k-1,0) */ + } else { +/* ilu=1 & A is lower */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - j - 1; + slassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) + ; +/* trap L at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + slassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); +/* U at A(0,1) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + slassq_(&k, a, &i__1, &scale, &s); +/* tri L at A(0,0) */ + i__1 = k - 1; + i__2 = lda + 1; + slassq_(&i__1, &a[lda], &i__2, &scale, &s); +/* tri U at A(0,1) */ + } + } else { +/* A is xpose */ + if (ilu == 0) { +/* A**T is upper */ + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + slassq_(&j, &a[(k + j) * lda], &c__1, &scale, &s); +/* U at A(0,k) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + slassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k-1 rect. at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + slassq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, & + scale, &s); +/* L at A(0,k-1) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = k - 1; + i__2 = lda + 1; + slassq_(&i__1, &a[k * lda], &i__2, &scale, &s); +/* tri U at A(0,k) */ + i__1 = lda + 1; + slassq_(&k, &a[(k - 1) * lda], &i__1, &scale, &s); +/* tri L at A(0,k-1) */ + } else { +/* A**T is lower */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + slassq_(&j, &a[j * lda], &c__1, &scale, &s); +/* U at A(0,0) */ + } + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + slassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k-1 rect. at A(0,k) */ + } + i__1 = k - 3; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 2; + slassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) + ; +/* L at A(1,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + slassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + i__1 = k - 1; + i__2 = lda + 1; + slassq_(&i__1, &a[1], &i__2, &scale, &s); +/* tri L at A(1,0) */ + } + } + } else { +/* n is even */ + if (ifm == 1) { +/* A is normal */ + if (ilu == 0) { +/* A is upper */ + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + slassq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale, + &s); +/* L at A(k+1,0) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + slassq_(&i__2, &a[j * lda], &c__1, &scale, &s); +/* trap U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + slassq_(&k, &a[k + 1], &i__1, &scale, &s); +/* tri L at A(k+1,0) */ + i__1 = lda + 1; + slassq_(&k, &a[k], &i__1, &scale, &s); +/* tri U at A(k,0) */ + } else { +/* ilu=1 & A is lower */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - j - 1; + slassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) + ; +/* trap L at A(1,0) */ + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + slassq_(&j, &a[j * lda], &c__1, &scale, &s); +/* U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + slassq_(&k, &a[1], &i__1, &scale, &s); +/* tri L at A(1,0) */ + i__1 = lda + 1; + slassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + } + } else { +/* A is xpose */ + if (ilu == 0) { +/* A**T is upper */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + slassq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s); +/* U at A(0,k+1) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + slassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k rect. at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + slassq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, & + scale, &s); +/* L at A(0,k) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + slassq_(&k, &a[(k + 1) * lda], &i__1, &scale, &s); +/* tri U at A(0,k+1) */ + i__1 = lda + 1; + slassq_(&k, &a[k * lda], &i__1, &scale, &s); +/* tri L at A(0,k) */ + } else { +/* A**T is lower */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + slassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); +/* U at A(0,1) */ + } + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + slassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k rect. at A(0,k+1) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + slassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) + ; +/* L at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + slassq_(&k, &a[lda], &i__1, &scale, &s); +/* tri L at A(0,1) */ + i__1 = lda + 1; + slassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + } + } + } + value = scale * sqrt(s); + } + + ret_val = value; + return ret_val; + +/* End of SLANSF */ + +} /* slansf_ */ + diff --git a/lapack-netlib/SRC/slansp.c b/lapack-netlib/SRC/slansp.c new file mode 100644 index 000000000..6c36fe36a --- /dev/null +++ b/lapack-netlib/SRC/slansp.c @@ -0,0 +1,707 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a symmetric matrix supplied in packed form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANSP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER N */ +/* REAL AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANSP returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > real symmetric matrix A, supplied in packed form. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANSP */ +/* > \verbatim */ +/* > */ +/* > SLANSP = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANSP as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is supplied. */ +/* > = 'U': Upper triangular part of A is supplied */ +/* > = 'L': Lower triangular part of A is supplied */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANSP is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL 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)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +real slansp_(char *norm, char *uplo, integer *n, real *ap, real *work) +{ + /* System generated locals */ + integer i__1, i__2; + real ret_val, r__1; + + /* Local variables */ + real absa; + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j, k; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --work; + --ap; + + /* Function Body */ + if (*n == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.f; + if (lsame_(uplo, "U")) { + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { + sum = (r__1 = ap[i__], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L10: */ + } + k += j; +/* L20: */ + } + } else { + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { + sum = (r__1 = ap[i__], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L30: */ + } + k = k + *n - j + 1; +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.f; + k = 1; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = (r__1 = ap[k], abs(r__1)); + sum += absa; + work[i__] += absa; + ++k; +/* L50: */ + } + work[j] = sum + (r__1 = ap[k], abs(r__1)); + ++k; +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (r__1 = ap[k], abs(r__1)); + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = (r__1 = ap[k], abs(r__1)); + sum += absa; + work[i__] += absa; + ++k; +/* L90: */ + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.f; + ssq[1] = 1.f; + +/* Sum off-diagonals */ + + k = 2; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = j - 1; + slassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); + k += j; +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = *n - j; + slassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L120: */ + } + } + ssq[1] *= 2; + +/* Sum diagonal */ + + k = 1; + colssq[0] = 0.f; + colssq[1] = 1.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ap[k] != 0.f) { + absa = (r__1 = ap[k], abs(r__1)); + if (colssq[0] < absa) { +/* Computing 2nd power */ + r__1 = colssq[0] / absa; + colssq[1] = colssq[1] * (r__1 * r__1) + 1.f; + colssq[0] = absa; + } else { +/* Computing 2nd power */ + r__1 = absa / colssq[0]; + colssq[1] += r__1 * r__1; + } + } + if (lsame_(uplo, "U")) { + k = k + i__ + 1; + } else { + k = k + *n - i__ + 1; + } +/* L130: */ + } + scombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANSP */ + +} /* slansp_ */ + diff --git a/lapack-netlib/SRC/slanst.c b/lapack-netlib/SRC/slanst.c new file mode 100644 index 000000000..30868ed00 --- /dev/null +++ b/lapack-netlib/SRC/slanst.c @@ -0,0 +1,587 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a real symmetric tridiagonal matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANST + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANST( NORM, N, D, E ) */ + +/* CHARACTER NORM */ +/* INTEGER N */ +/* REAL D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANST returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > real symmetric tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANST */ +/* > \verbatim */ +/* > */ +/* > SLANST = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANST as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANST is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > The (n-1) sub-diagonal or super-diagonal elements of A. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +real slanst_(char *norm, integer *n, real *d__, real *e) +{ + /* System generated locals */ + integer i__1; + real ret_val, r__1, r__2, r__3; + + /* Local variables */ + integer i__; + real scale; + extern logical lsame_(char *, char *); + real anorm; + extern logical sisnan_(real *); + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + if (*n <= 0) { + anorm = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + anorm = (r__1 = d__[*n], abs(r__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = (r__1 = d__[i__], abs(r__1)); + if (anorm < sum || sisnan_(&sum)) { + anorm = sum; + } + sum = (r__1 = e[i__], abs(r__1)); + if (anorm < sum || sisnan_(&sum)) { + anorm = sum; + } +/* L10: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1' || lsame_(norm, "I")) { + +/* Find norm1(A). */ + + if (*n == 1) { + anorm = abs(d__[1]); + } else { + anorm = abs(d__[1]) + abs(e[1]); + sum = (r__1 = e[*n - 1], abs(r__1)) + (r__2 = d__[*n], abs(r__2)); + if (anorm < sum || sisnan_(&sum)) { + anorm = sum; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + sum = (r__1 = d__[i__], abs(r__1)) + (r__2 = e[i__], abs(r__2) + ) + (r__3 = e[i__ - 1], abs(r__3)); + if (anorm < sum || sisnan_(&sum)) { + anorm = sum; + } +/* L20: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.f; + sum = 1.f; + if (*n > 1) { + i__1 = *n - 1; + slassq_(&i__1, &e[1], &c__1, &scale, &sum); + sum *= 2; + } + slassq_(n, &d__[1], &c__1, &scale, &sum); + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of SLANST */ + +} /* slanst_ */ + diff --git a/lapack-netlib/SRC/slansy.c b/lapack-netlib/SRC/slansy.c new file mode 100644 index 000000000..f4d19eee4 --- /dev/null +++ b/lapack-netlib/SRC/slansy.c @@ -0,0 +1,686 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a real symmetric matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANSY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER LDA, N */ +/* REAL A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANSY returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > real symmetric matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANSY */ +/* > \verbatim */ +/* > */ +/* > SLANSY = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANSY as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is to be referenced. */ +/* > = 'U': Upper triangular part of A is referenced */ +/* > = 'L': Lower triangular part of A is referenced */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANSY is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL 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(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYauxiliary */ + +/* ===================================================================== */ +real slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda, real * + work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real ret_val, r__1; + + /* Local variables */ + real absa; + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + sum = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + sum += absa; + work[i__] += absa; +/* L50: */ + } + work[j] = sum + (r__1 = a[j + j * a_dim1], abs(r__1)); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (r__1 = a[j + j * a_dim1], abs(r__1)); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + sum += absa; + work[i__] += absa; +/* L90: */ + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.f; + ssq[1] = 1.f; + +/* Sum off-diagonals */ + + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = j - 1; + slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = *n - j; + slassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, colssq, &colssq[ + 1]); + scombssq_(ssq, colssq); +/* L120: */ + } + } + ssq[1] *= 2; + +/* Sum diagonal */ + + colssq[0] = 0.f; + colssq[1] = 1.f; + i__1 = *lda + 1; + slassq_(n, &a[a_offset], &i__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANSY */ + +} /* slansy_ */ + diff --git a/lapack-netlib/SRC/slantb.c b/lapack-netlib/SRC/slantb.c new file mode 100644 index 000000000..d65e9d1b1 --- /dev/null +++ b/lapack-netlib/SRC/slantb.c @@ -0,0 +1,886 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a triangular band matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANTB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, */ +/* LDAB, WORK ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER K, LDAB, N */ +/* REAL AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANTB returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of an */ +/* > n by n triangular band matrix A, with ( k + 1 ) diagonals. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANTB */ +/* > \verbatim */ +/* > */ +/* > SLANTB = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANTB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANTB is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* > or the number of sub-diagonals of the matrix A if UPLO = 'L'. */ +/* > K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first k+1 rows of AB. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for f2cmax(1,j-k)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+k). */ +/* > Note that when DIAG = 'U', the elements of the array AB */ +/* > corresponding to the diagonal elements of the matrix A are */ +/* > not referenced, but are assumed to be one. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= K+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +real slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, real + *ab, integer *ldab, real *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; + real ret_val, r__1; + + /* Local variables */ + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j, l; + logical udiag; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + if (lsame_(diag, "U")) { + value = 1.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + sum = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *n + 1 - j, i__4 = *k + 1; + i__3 = f2cmin(i__2,i__4); + for (i__ = 2; i__ <= i__3; ++i__) { + sum = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else { + value = 0.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = *k + 2 - j; + i__2 = *k + 1; + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { + sum = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L70: */ + } +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.f; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.f; +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + sum += (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); +/* L90: */ + } + } else { + sum = 0.f; +/* Computing MAX */ + i__3 = *k + 2 - j; + i__2 = *k + 1; + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { + sum += (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); +/* L100: */ + } + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.f; +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 2; i__ <= i__2; ++i__) { + sum += (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); +/* L120: */ + } + } else { + sum = 0.f; +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); +/* L130: */ + } + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + value = 0.f; + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.f; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = *k + 1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], abs( + r__1)); +/* L160: */ + } +/* L170: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = *k + 1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j; + for (i__ = f2cmax(i__4,i__2); i__ <= i__3; ++i__) { + work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], abs( + r__1)); +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.f; +/* L210: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = f2cmin(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], abs( + r__1)); +/* L220: */ + } +/* L230: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L240: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = f2cmin(i__4,i__2); + for (i__ = j; i__ <= i__3; ++i__) { + work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], abs( + r__1)); +/* L250: */ + } +/* L260: */ + } + } + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L270: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + ssq[0] = 1.f; + ssq[1] = (real) (*n); + if (*k > 0) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__4 = j - 1; + i__3 = f2cmin(i__4,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + slassq_(&i__3, &ab[f2cmax(i__2,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L280: */ + } + } + } else { + ssq[0] = 0.f; + ssq[1] = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__4 = j, i__2 = *k + 1; + i__3 = f2cmin(i__4,i__2); +/* Computing MAX */ + i__5 = *k + 2 - j; + slassq_(&i__3, &ab[f2cmax(i__5,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L290: */ + } + } + } else { + if (lsame_(diag, "U")) { + ssq[0] = 1.f; + ssq[1] = (real) (*n); + if (*k > 0) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__4 = *n - j; + i__3 = f2cmin(i__4,*k); + slassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, colssq, & + colssq[1]); + scombssq_(ssq, colssq); +/* L300: */ + } + } + } else { + ssq[0] = 0.f; + ssq[1] = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__4 = *n - j + 1, i__2 = *k + 1; + i__3 = f2cmin(i__4,i__2); + slassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, colssq, & + colssq[1]); + scombssq_(ssq, colssq); +/* L310: */ + } + } + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANTB */ + +} /* slantb_ */ + diff --git a/lapack-netlib/SRC/slantp.c b/lapack-netlib/SRC/slantp.c new file mode 100644 index 000000000..91cc5820f --- /dev/null +++ b/lapack-netlib/SRC/slantp.c @@ -0,0 +1,839 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a triangular matrix supplied in packed form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER N */ +/* REAL AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANTP returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > triangular matrix A, supplied in packed form. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANTP */ +/* > \verbatim */ +/* > */ +/* > SLANTP = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANTP as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, SLANTP is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangular matrix A, packed columnwise in */ +/* > a linear array. The j-th column of A is stored in the array */ +/* > AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > Note that when DIAG = 'U', the elements of the array AP */ +/* > corresponding to the diagonal elements of the matrix A are */ +/* > not referenced, but are assumed to be one. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +real slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, real * + work) +{ + /* System generated locals */ + integer i__1, i__2; + real ret_val, r__1; + + /* Local variables */ + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j, k; + logical udiag; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --work; + --ap; + + /* Function Body */ + if (*n == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + k = 1; + if (lsame_(diag, "U")) { + value = 1.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 2; + for (i__ = k; i__ <= i__2; ++i__) { + sum = (r__1 = ap[i__], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L10: */ + } + k += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k + 1; i__ <= i__2; ++i__) { + sum = (r__1 = ap[i__], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L30: */ + } + k = k + *n - j + 1; +/* L40: */ + } + } + } else { + value = 0.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { + sum = (r__1 = ap[i__], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L50: */ + } + k += j; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { + sum = (r__1 = ap[i__], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L70: */ + } + k = k + *n - j + 1; +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.f; + k = 1; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.f; + i__2 = k + j - 2; + for (i__ = k; i__ <= i__2; ++i__) { + sum += (r__1 = ap[i__], abs(r__1)); +/* L90: */ + } + } else { + sum = 0.f; + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { + sum += (r__1 = ap[i__], abs(r__1)); +/* L100: */ + } + } + k += j; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.f; + i__2 = k + *n - j; + for (i__ = k + 1; i__ <= i__2; ++i__) { + sum += (r__1 = ap[i__], abs(r__1)); +/* L120: */ + } + } else { + sum = 0.f; + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { + sum += (r__1 = ap[i__], abs(r__1)); +/* L130: */ + } + } + k = k + *n - j + 1; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + k = 1; + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.f; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = ap[k], abs(r__1)); + ++k; +/* L160: */ + } + ++k; +/* L170: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = ap[k], abs(r__1)); + ++k; +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.f; +/* L210: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = ap[k], abs(r__1)); + ++k; +/* L220: */ + } +/* L230: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L240: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + work[i__] += (r__1 = ap[k], abs(r__1)); + ++k; +/* L250: */ + } +/* L260: */ + } + } + } + value = 0.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L270: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + ssq[0] = 1.f; + ssq[1] = (real) (*n); + k = 2; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = j - 1; + slassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); + k += j; +/* L280: */ + } + } else { + ssq[0] = 0.f; + ssq[1] = 1.f; + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + slassq_(&j, &ap[k], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); + k += j; +/* L290: */ + } + } + } else { + if (lsame_(diag, "U")) { + ssq[0] = 1.f; + ssq[1] = (real) (*n); + k = 2; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = *n - j; + slassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L300: */ + } + } else { + ssq[0] = 0.f; + ssq[1] = 1.f; + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = *n - j + 1; + slassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + scombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L310: */ + } + } + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANTP */ + +} /* slantp_ */ + diff --git a/lapack-netlib/SRC/slantr.c b/lapack-netlib/SRC/slantr.c new file mode 100644 index 000000000..31edecb40 --- /dev/null +++ b/lapack-netlib/SRC/slantr.c @@ -0,0 +1,852 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a trapezoidal or triangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, */ +/* WORK ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER LDA, M, N */ +/* REAL A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANTR returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > trapezoidal or triangular matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return SLANTR */ +/* > \verbatim */ +/* > */ +/* > SLANTR = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in SLANTR as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower trapezoidal. */ +/* > = 'U': Upper trapezoidal */ +/* > = 'L': Lower trapezoidal */ +/* > Note that A is triangular instead of trapezoidal if M = N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A has unit diagonal. */ +/* > = 'N': Non-unit diagonal */ +/* > = 'U': Unit diagonal */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0, and if */ +/* > UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0, and if */ +/* > UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The trapezoidal matrix A (A is triangular if M = N). */ +/* > If UPLO = 'U', the leading m by n upper trapezoidal part of */ +/* > the array A contains the upper trapezoidal matrix, and the */ +/* > strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the leading m by n lower trapezoidal part of */ +/* > the array A contains the lower trapezoidal matrix, and the */ +/* > strictly upper triangular part of A is not referenced. Note */ +/* > that when DIAG = 'U', the diagonal elements of A are not */ +/* > referenced and are assumed to be one. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(M,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +real slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, real + *a, integer *lda, real *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + real ret_val, r__1; + + /* Local variables */ + extern /* Subroutine */ int scombssq_(real *, real *); + integer i__, j; + logical udiag; + extern logical lsame_(char *, char *); + real value; + extern logical sisnan_(real *); + real colssq[2]; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0) { + value = 0.f; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + if (lsame_(diag, "U")) { + value = 1.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else { + value = 0.f; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + sum = (r__1 = a[i__ + j * a_dim1], abs(r__1)); + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L70: */ + } +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.f; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag && j <= *m) { + sum = 1.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L90: */ + } + } else { + sum = 0.f; + i__2 = f2cmin(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L100: */ + } + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.f; + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L120: */ + } + } else { + sum = 0.f; + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + sum += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L130: */ + } + } + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.f; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L160: */ + } +/* L170: */ + } + } else { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.f; +/* L210: */ + } + i__1 = *m; + for (i__ = *n + 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L220: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L230: */ + } +/* L240: */ + } + } else { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L250: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)); +/* L260: */ + } +/* L270: */ + } + } + } + value = 0.f; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || sisnan_(&sum)) { + value = sum; + } +/* L280: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + ssq[0] = 1.f; + ssq[1] = (real) f2cmin(*m,*n); + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = f2cmin(i__3,i__4); + slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[ + 1]); + scombssq_(ssq, colssq); +/* L290: */ + } + } else { + ssq[0] = 0.f; + ssq[1] = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = f2cmin(*m,j); + slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[ + 1]); + scombssq_(ssq, colssq); +/* L300: */ + } + } + } else { + if (lsame_(diag, "U")) { + ssq[0] = 1.f; + ssq[1] = (real) f2cmin(*m,*n); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = *m - j; +/* Computing MIN */ + i__3 = *m, i__4 = j + 1; + slassq_(&i__2, &a[f2cmin(i__3,i__4) + j * a_dim1], &c__1, + colssq, &colssq[1]); + scombssq_(ssq, colssq); +/* L310: */ + } + } else { + ssq[0] = 0.f; + ssq[1] = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.f; + colssq[1] = 1.f; + i__2 = *m - j + 1; + slassq_(&i__2, &a[j + j * a_dim1], &c__1, colssq, &colssq[ + 1]); + scombssq_(ssq, colssq); +/* L320: */ + } + } + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of SLANTR */ + +} /* slantr_ */ + diff --git a/lapack-netlib/SRC/slanv2.c b/lapack-netlib/SRC/slanv2.c new file mode 100644 index 000000000..7468429c4 --- /dev/null +++ b/lapack-netlib/SRC/slanv2.c @@ -0,0 +1,707 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLANV2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) */ + +/* REAL A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */ +/* > matrix in standard form: */ +/* > */ +/* > [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */ +/* > [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */ +/* > */ +/* > where either */ +/* > 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */ +/* > 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */ +/* > conjugate eigenvalues. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL */ +/* > On entry, the elements of the input matrix. */ +/* > On exit, they are overwritten by the elements of the */ +/* > standardised Schur form. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1R */ +/* > \verbatim */ +/* > RT1R is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1I */ +/* > \verbatim */ +/* > RT1I is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2R */ +/* > \verbatim */ +/* > RT2R is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2I */ +/* > \verbatim */ +/* > RT2I is REAL */ +/* > The real and imaginary parts of the eigenvalues. If the */ +/* > eigenvalues are a complex conjugate pair, RT1I > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS */ +/* > \verbatim */ +/* > CS is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN */ +/* > \verbatim */ +/* > SN is REAL */ +/* > Parameters of the rotation matrix. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Modified by V. Sima, Research Institute for Informatics, Bucharest, */ +/* > Romania, to reduce the risk of cancellation errors, */ +/* > when computing real eigenvalues, and to ensure, if possible, that */ +/* > abs(RT1R) >= abs(RT2R). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real * + rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real temp, p, scale, bcmax, z__, bcmis, sigma; + integer count; + real safmn2, safmx2, aa, bb, cc, dd; + extern real slapy2_(real *, real *), slamch_(char *); + real safmin, cs1, sn1, sab, sac, eps, tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + safmin = slamch_("S"); + eps = slamch_("P"); + r__1 = slamch_("B"); + i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f); + safmn2 = pow_ri(&r__1, &i__1); + safmx2 = 1.f / safmn2; + if (*c__ == 0.f) { + *cs = 1.f; + *sn = 0.f; + + } else if (*b == 0.f) { + +/* Swap rows and columns */ + + *cs = 0.f; + *sn = 1.f; + temp = *d__; + *d__ = *a; + *a = temp; + *b = -(*c__); + *c__ = 0.f; + + } else if (*a - *d__ == 0.f && r_sign(&c_b6, b) != r_sign(&c_b6, c__)) { + *cs = 1.f; + *sn = 0.f; + + } else { + + temp = *a - *d__; + p = temp * .5f; +/* Computing MAX */ + r__1 = abs(*b), r__2 = abs(*c__); + bcmax = f2cmax(r__1,r__2); +/* Computing MIN */ + r__1 = abs(*b), r__2 = abs(*c__); + bcmis = f2cmin(r__1,r__2) * r_sign(&c_b6, b) * r_sign(&c_b6, c__); +/* Computing MAX */ + r__1 = abs(p); + scale = f2cmax(r__1,bcmax); + z__ = p / scale * p + bcmax / scale * bcmis; + +/* If Z is of the order of the machine accuracy, postpone the */ +/* decision on the nature of eigenvalues */ + + if (z__ >= eps * 4.f) { + +/* Real eigenvalues. Compute A and D. */ + + r__1 = sqrt(scale) * sqrt(z__); + z__ = p + r_sign(&r__1, &p); + *a = *d__ + z__; + *d__ -= bcmax / z__ * bcmis; + +/* Compute B and the rotation matrix */ + + tau = slapy2_(c__, &z__); + *cs = z__ / tau; + *sn = *c__ / tau; + *b -= *c__; + *c__ = 0.f; + + } else { + +/* Complex eigenvalues, or real (almost) equal eigenvalues. */ +/* Make diagonal elements equal. */ + + count = 0; + sigma = *b + *c__; +L10: + ++count; +/* Computing MAX */ + r__1 = abs(temp), r__2 = abs(sigma); + scale = f2cmax(r__1,r__2); + if (scale >= safmx2) { + sigma *= safmn2; + temp *= safmn2; + if (count <= 20) { + goto L10; + } + } + if (scale <= safmn2) { + sigma *= safmx2; + temp *= safmx2; + if (count <= 20) { + goto L10; + } + } + p = temp * .5f; + tau = slapy2_(&sigma, &temp); + *cs = sqrt((abs(sigma) / tau + 1.f) * .5f); + *sn = -(p / (tau * *cs)) * r_sign(&c_b6, &sigma); + +/* Compute [ AA BB ] = [ A B ] [ CS -SN ] */ +/* [ CC DD ] [ C D ] [ SN CS ] */ + + aa = *a * *cs + *b * *sn; + bb = -(*a) * *sn + *b * *cs; + cc = *c__ * *cs + *d__ * *sn; + dd = -(*c__) * *sn + *d__ * *cs; + +/* Compute [ A B ] = [ CS SN ] [ AA BB ] */ +/* [ C D ] [-SN CS ] [ CC DD ] */ + + *a = aa * *cs + cc * *sn; + *b = bb * *cs + dd * *sn; + *c__ = -aa * *sn + cc * *cs; + *d__ = -bb * *sn + dd * *cs; + + temp = (*a + *d__) * .5f; + *a = temp; + *d__ = temp; + + if (*c__ != 0.f) { + if (*b != 0.f) { + if (r_sign(&c_b6, b) == r_sign(&c_b6, c__)) { + +/* Real eigenvalues: reduce to upper triangular form */ + + sab = sqrt((abs(*b))); + sac = sqrt((abs(*c__))); + r__1 = sab * sac; + p = r_sign(&r__1, c__); + tau = 1.f / sqrt((r__1 = *b + *c__, abs(r__1))); + *a = temp + p; + *d__ = temp - p; + *b -= *c__; + *c__ = 0.f; + cs1 = sab * tau; + sn1 = sac * tau; + temp = *cs * cs1 - *sn * sn1; + *sn = *cs * sn1 + *sn * cs1; + *cs = temp; + } + } else { + *b = -(*c__); + *c__ = 0.f; + temp = *cs; + *cs = -(*sn); + *sn = temp; + } + } + } + + } + +/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */ + + *rt1r = *a; + *rt2r = *d__; + if (*c__ == 0.f) { + *rt1i = 0.f; + *rt2i = 0.f; + } else { + *rt1i = sqrt((abs(*b))) * sqrt((abs(*c__))); + *rt2i = -(*rt1i); + } + return 0; + +/* End of SLANV2 */ + +} /* slanv2_ */ + diff --git a/lapack-netlib/SRC/slaorhr_col_getrfnp.c b/lapack-netlib/SRC/slaorhr_col_getrfnp.c new file mode 100644 index 000000000..c644fe3e9 --- /dev/null +++ b/lapack-netlib/SRC/slaorhr_col_getrfnp.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 \b SLAORHR_COL_GETRFNP */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAORHR_COL_GETRFNP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAORHR_COL_GETRFNP( M, N, A, LDA, D, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* REAL A( LDA, * ), D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAORHR_COL_GETRFNP computes the modified LU factorization without */ +/* > pivoting of a real general M-by-N matrix A. The factorization has */ +/* > the form: */ +/* > */ +/* > A - S = L * U, */ +/* > */ +/* > where: */ +/* > S is a m-by-n diagonal sign matrix with the diagonal D, so that */ +/* > D(i) = S(i,i), 1 <= i <= f2cmin(M,N). The diagonal D is constructed */ +/* > as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing */ +/* > i-1 steps of Gaussian elimination. This means that the diagonal */ +/* > element at each step of "modified" Gaussian elimination is */ +/* > at least one in absolute value (so that division-by-zero not */ +/* > not possible during the division by the diagonal element); */ +/* > */ +/* > L is a M-by-N lower triangular matrix with unit diagonal elements */ +/* > (lower trapezoidal if M > N); */ +/* > */ +/* > and U is a M-by-N upper triangular matrix */ +/* > (upper trapezoidal if M < N). */ +/* > */ +/* > This routine is an auxiliary routine used in the Householder */ +/* > reconstruction routine SORHR_COL. In SORHR_COL, this routine is */ +/* > applied to an M-by-N matrix A with orthonormal columns, where each */ +/* > element is bounded by one in absolute value. With the choice of */ +/* > the matrix S above, one can show that the diagonal element at each */ +/* > step of Gaussian elimination is the largest (in absolute value) in */ +/* > the column on or below the diagonal, so that no pivoting is required */ +/* > for numerical stability [1]. */ +/* > */ +/* > For more details on the Householder reconstruction algorithm, */ +/* > including the modified LU factorization, see [1]. */ +/* > */ +/* > This is the blocked right-looking version of the algorithm, */ +/* > calling Level 3 BLAS to update the submatrix. To factorize a block, */ +/* > this routine calls the recursive routine SLAORHR_COL_GETRFNP2. */ +/* > */ +/* > [1] "Reconstructing Householder vectors from tall-skinny QR", */ +/* > G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, */ +/* > E. Solomonik, J. Parallel Distrib. Comput., */ +/* > vol. 85, pp. 3-31, 2015. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix to be factored. */ +/* > On exit, the factors L and U from the factorization */ +/* > A-S=L*U; the unit diagonal elements of L are not stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension f2cmin(M,N) */ +/* > The diagonal elements of the diagonal M-by-N sign matrix S, */ +/* > D(i) = S(i,i), where 1 <= i <= f2cmin(M,N). The elements can */ +/* > be only plus or minus one. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ +/* > */ +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup realGEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2019, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int slaorhr_col_getrfnp_(integer *m, integer *n, real *a, + integer *lda, real *d__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + extern /* Subroutine */ int slaorhr_col_getrfnp2_(integer *, integer *, + real *, integer *, real *, integer *); + integer j, iinfo; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *), strsm_(char *, char *, char *, + char *, integer *, integer *, real *, real *, integer *, real *, + integer *); + integer jb, 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.9.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAORHR_COL_GETRFNP", &i__1, (ftnlen)19); + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "SLAORHR_COL_GETRFNP", " ", m, n, &c_n1, &c_n1, ( + ftnlen)19, (ftnlen)1); + if (nb <= 1 || nb >= f2cmin(*m,*n)) { + +/* Use unblocked code. */ + + slaorhr_col_getrfnp2_(m, n, &a[a_offset], lda, &d__[1], info); + } else { + +/* Use blocked code. */ + + i__1 = f2cmin(*m,*n); + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = f2cmin(*m,*n) - j + 1; + jb = f2cmin(i__3,nb); + +/* Factor diagonal and subdiagonal blocks. */ + + i__3 = *m - j + 1; + slaorhr_col_getrfnp2_(&i__3, &jb, &a[j + j * a_dim1], lda, &d__[ + j], &iinfo); + + if (j + jb <= *n) { + +/* Compute block row of U. */ + + i__3 = *n - j - jb + 1; + strsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, & + c_b12, &a[j + j * a_dim1], lda, &a[j + (j + jb) * + a_dim1], lda); + if (j + jb <= *m) { + +/* Update trailing submatrix. */ + + i__3 = *m - j - jb + 1; + i__4 = *n - j - jb + 1; + sgemm_("No transpose", "No transpose", &i__3, &i__4, &jb, + &c_b15, &a[j + jb + j * a_dim1], lda, &a[j + (j + + jb) * a_dim1], lda, &c_b12, &a[j + jb + (j + jb) * + a_dim1], lda); + } + } + } + } + return 0; + +/* End of SLAORHR_COL_GETRFNP */ + +} /* slaorhr_col_getrfnp__ */ +