From b542c1d72b91dd1e41371402872c14b53a384bdd Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 23 Feb 2022 00:03:16 +0100 Subject: [PATCH] Add C versions as fallback --- lapack-netlib/SRC/dgetsqrhrt.c | 768 +++++++++ lapack-netlib/SRC/dggbak.c | 722 +++++++++ lapack-netlib/SRC/dggbal.c | 1071 ++++++++++++ lapack-netlib/SRC/dgges.c | 1167 +++++++++++++ lapack-netlib/SRC/dgges3.c | 1169 +++++++++++++ lapack-netlib/SRC/dggesx.c | 1316 +++++++++++++++ lapack-netlib/SRC/dggev.c | 1102 +++++++++++++ lapack-netlib/SRC/dggev3.c | 1122 +++++++++++++ lapack-netlib/SRC/dggevx.c | 1396 ++++++++++++++++ lapack-netlib/SRC/dggglm.c | 793 +++++++++ lapack-netlib/SRC/dgghd3.c | 1457 +++++++++++++++++ lapack-netlib/SRC/dgghrd.c | 784 +++++++++ lapack-netlib/SRC/dgglse.c | 792 +++++++++ lapack-netlib/SRC/dggqrf.c | 718 ++++++++ lapack-netlib/SRC/dggrqf.c | 719 ++++++++ lapack-netlib/SRC/dggsvd3.c | 938 +++++++++++ lapack-netlib/SRC/dggsvp3.c | 1058 ++++++++++++ lapack-netlib/SRC/dgsvj0.c | 1601 ++++++++++++++++++ lapack-netlib/SRC/dgsvj1.c | 1239 ++++++++++++++ lapack-netlib/SRC/dgtcon.c | 652 ++++++++ lapack-netlib/SRC/dgtrfs.c | 919 +++++++++++ lapack-netlib/SRC/dgtsv.c | 746 +++++++++ lapack-netlib/SRC/dgtsvx.c | 830 ++++++++++ lapack-netlib/SRC/dgttrf.c | 632 ++++++++ lapack-netlib/SRC/dgttrs.c | 634 ++++++++ lapack-netlib/SRC/dgtts2.c | 706 ++++++++ lapack-netlib/SRC/dhgeqz.c | 1985 +++++++++++++++++++++++ lapack-netlib/SRC/dhsein.c | 972 +++++++++++ lapack-netlib/SRC/dhseqr.c | 945 +++++++++++ lapack-netlib/SRC/disnan.c | 469 ++++++ lapack-netlib/SRC/dla_gbamv.c | 818 ++++++++++ lapack-netlib/SRC/dla_gbrcond.c | 791 +++++++++ lapack-netlib/SRC/dla_gbrfsx_extended.c | 1143 +++++++++++++ lapack-netlib/SRC/dla_gbrpvgrw.c | 569 +++++++ lapack-netlib/SRC/dla_geamv.c | 779 +++++++++ lapack-netlib/SRC/dla_gercond.c | 738 +++++++++ lapack-netlib/SRC/dla_gerfsx_extended.c | 1122 +++++++++++++ lapack-netlib/SRC/dla_gerpvgrw.c | 544 +++++++ lapack-netlib/SRC/dla_lin_berr.c | 548 +++++++ lapack-netlib/SRC/dla_porcond.c | 746 +++++++++ lapack-netlib/SRC/dla_porfsx_extended.c | 1098 +++++++++++++ lapack-netlib/SRC/dla_porpvgrw.c | 626 +++++++ lapack-netlib/SRC/dla_syamv.c | 802 +++++++++ lapack-netlib/SRC/dla_syrcond.c | 764 +++++++++ lapack-netlib/SRC/dla_syrfsx_extended.c | 1132 +++++++++++++ lapack-netlib/SRC/dla_syrpvgrw.c | 764 +++++++++ lapack-netlib/SRC/dla_wwaddw.c | 505 ++++++ lapack-netlib/SRC/dlabad.c | 489 ++++++ lapack-netlib/SRC/dlabrd.c | 885 ++++++++++ lapack-netlib/SRC/dlacn2.c | 702 ++++++++ lapack-netlib/SRC/dlacon.c | 681 ++++++++ lapack-netlib/SRC/dlacpy.c | 556 +++++++ lapack-netlib/SRC/dladiv.c | 624 +++++++ lapack-netlib/SRC/dlae2.c | 567 +++++++ lapack-netlib/SRC/dlaebz.c | 1100 +++++++++++++ lapack-netlib/SRC/dlaed0.c | 880 ++++++++++ lapack-netlib/SRC/dlaed1.c | 691 ++++++++ lapack-netlib/SRC/dlaed2.c | 995 ++++++++++++ lapack-netlib/SRC/dlaed3.c | 786 +++++++++ lapack-netlib/SRC/dlaed4.c | 1379 ++++++++++++++++ lapack-netlib/SRC/dlaed5.c | 572 +++++++ lapack-netlib/SRC/dlaed6.c | 812 +++++++++ lapack-netlib/SRC/dlaed7.c | 832 ++++++++++ lapack-netlib/SRC/dlaed8.c | 959 +++++++++++ lapack-netlib/SRC/dlaed9.c | 721 ++++++++ lapack-netlib/SRC/dlaeda.c | 735 +++++++++ lapack-netlib/SRC/dlaein.c | 1136 +++++++++++++ lapack-netlib/SRC/dlaev2.c | 619 +++++++ lapack-netlib/SRC/dlaexc.c | 900 ++++++++++ lapack-netlib/SRC/dlag2.c | 795 +++++++++ lapack-netlib/SRC/dlag2s.c | 547 +++++++ lapack-netlib/SRC/dlags2.c | 751 +++++++++ lapack-netlib/SRC/dlagtf.c | 662 ++++++++ lapack-netlib/SRC/dlagtm.c | 705 ++++++++ lapack-netlib/SRC/dlagts.c | 787 +++++++++ lapack-netlib/SRC/dlagv2.c | 797 +++++++++ lapack-netlib/SRC/dlahqr.c | 1090 +++++++++++++ lapack-netlib/SRC/dlahr2.c | 766 +++++++++ lapack-netlib/SRC/dlaic1.c | 757 +++++++++ lapack-netlib/SRC/dlaisnan.c | 481 ++++++ lapack-netlib/SRC/dlaln2.c | 1032 ++++++++++++ lapack-netlib/SRC/dlals0.c | 955 +++++++++++ lapack-netlib/SRC/dlalsa.c | 951 +++++++++++ lapack-netlib/SRC/dlalsd.c | 978 +++++++++++ lapack-netlib/SRC/dlamrg.c | 566 +++++++ lapack-netlib/SRC/dlamswlq.c | 845 ++++++++++ lapack-netlib/SRC/dlamtsqr.c | 843 ++++++++++ lapack-netlib/SRC/dlaneg.c | 642 ++++++++ lapack-netlib/SRC/dlangb.c | 662 ++++++++ lapack-netlib/SRC/dlange.c | 633 ++++++++ lapack-netlib/SRC/dlangt.c | 625 +++++++ lapack-netlib/SRC/dlanhs.c | 635 ++++++++ lapack-netlib/SRC/dlansb.c | 713 ++++++++ lapack-netlib/SRC/dlansf.c | 1480 +++++++++++++++++ lapack-netlib/SRC/dlansp.c | 707 ++++++++ lapack-netlib/SRC/dlanst.c | 587 +++++++ 96 files changed, 81524 insertions(+) create mode 100644 lapack-netlib/SRC/dgetsqrhrt.c create mode 100644 lapack-netlib/SRC/dggbak.c create mode 100644 lapack-netlib/SRC/dggbal.c create mode 100644 lapack-netlib/SRC/dgges.c create mode 100644 lapack-netlib/SRC/dgges3.c create mode 100644 lapack-netlib/SRC/dggesx.c create mode 100644 lapack-netlib/SRC/dggev.c create mode 100644 lapack-netlib/SRC/dggev3.c create mode 100644 lapack-netlib/SRC/dggevx.c create mode 100644 lapack-netlib/SRC/dggglm.c create mode 100644 lapack-netlib/SRC/dgghd3.c create mode 100644 lapack-netlib/SRC/dgghrd.c create mode 100644 lapack-netlib/SRC/dgglse.c create mode 100644 lapack-netlib/SRC/dggqrf.c create mode 100644 lapack-netlib/SRC/dggrqf.c create mode 100644 lapack-netlib/SRC/dggsvd3.c create mode 100644 lapack-netlib/SRC/dggsvp3.c create mode 100644 lapack-netlib/SRC/dgsvj0.c create mode 100644 lapack-netlib/SRC/dgsvj1.c create mode 100644 lapack-netlib/SRC/dgtcon.c create mode 100644 lapack-netlib/SRC/dgtrfs.c create mode 100644 lapack-netlib/SRC/dgtsv.c create mode 100644 lapack-netlib/SRC/dgtsvx.c create mode 100644 lapack-netlib/SRC/dgttrf.c create mode 100644 lapack-netlib/SRC/dgttrs.c create mode 100644 lapack-netlib/SRC/dgtts2.c create mode 100644 lapack-netlib/SRC/dhgeqz.c create mode 100644 lapack-netlib/SRC/dhsein.c create mode 100644 lapack-netlib/SRC/dhseqr.c create mode 100644 lapack-netlib/SRC/disnan.c create mode 100644 lapack-netlib/SRC/dla_gbamv.c create mode 100644 lapack-netlib/SRC/dla_gbrcond.c create mode 100644 lapack-netlib/SRC/dla_gbrfsx_extended.c create mode 100644 lapack-netlib/SRC/dla_gbrpvgrw.c create mode 100644 lapack-netlib/SRC/dla_geamv.c create mode 100644 lapack-netlib/SRC/dla_gercond.c create mode 100644 lapack-netlib/SRC/dla_gerfsx_extended.c create mode 100644 lapack-netlib/SRC/dla_gerpvgrw.c create mode 100644 lapack-netlib/SRC/dla_lin_berr.c create mode 100644 lapack-netlib/SRC/dla_porcond.c create mode 100644 lapack-netlib/SRC/dla_porfsx_extended.c create mode 100644 lapack-netlib/SRC/dla_porpvgrw.c create mode 100644 lapack-netlib/SRC/dla_syamv.c create mode 100644 lapack-netlib/SRC/dla_syrcond.c create mode 100644 lapack-netlib/SRC/dla_syrfsx_extended.c create mode 100644 lapack-netlib/SRC/dla_syrpvgrw.c create mode 100644 lapack-netlib/SRC/dla_wwaddw.c create mode 100644 lapack-netlib/SRC/dlabad.c create mode 100644 lapack-netlib/SRC/dlabrd.c create mode 100644 lapack-netlib/SRC/dlacn2.c create mode 100644 lapack-netlib/SRC/dlacon.c create mode 100644 lapack-netlib/SRC/dlacpy.c create mode 100644 lapack-netlib/SRC/dladiv.c create mode 100644 lapack-netlib/SRC/dlae2.c create mode 100644 lapack-netlib/SRC/dlaebz.c create mode 100644 lapack-netlib/SRC/dlaed0.c create mode 100644 lapack-netlib/SRC/dlaed1.c create mode 100644 lapack-netlib/SRC/dlaed2.c create mode 100644 lapack-netlib/SRC/dlaed3.c create mode 100644 lapack-netlib/SRC/dlaed4.c create mode 100644 lapack-netlib/SRC/dlaed5.c create mode 100644 lapack-netlib/SRC/dlaed6.c create mode 100644 lapack-netlib/SRC/dlaed7.c create mode 100644 lapack-netlib/SRC/dlaed8.c create mode 100644 lapack-netlib/SRC/dlaed9.c create mode 100644 lapack-netlib/SRC/dlaeda.c create mode 100644 lapack-netlib/SRC/dlaein.c create mode 100644 lapack-netlib/SRC/dlaev2.c create mode 100644 lapack-netlib/SRC/dlaexc.c create mode 100644 lapack-netlib/SRC/dlag2.c create mode 100644 lapack-netlib/SRC/dlag2s.c create mode 100644 lapack-netlib/SRC/dlags2.c create mode 100644 lapack-netlib/SRC/dlagtf.c create mode 100644 lapack-netlib/SRC/dlagtm.c create mode 100644 lapack-netlib/SRC/dlagts.c create mode 100644 lapack-netlib/SRC/dlagv2.c create mode 100644 lapack-netlib/SRC/dlahqr.c create mode 100644 lapack-netlib/SRC/dlahr2.c create mode 100644 lapack-netlib/SRC/dlaic1.c create mode 100644 lapack-netlib/SRC/dlaisnan.c create mode 100644 lapack-netlib/SRC/dlaln2.c create mode 100644 lapack-netlib/SRC/dlals0.c create mode 100644 lapack-netlib/SRC/dlalsa.c create mode 100644 lapack-netlib/SRC/dlalsd.c create mode 100644 lapack-netlib/SRC/dlamrg.c create mode 100644 lapack-netlib/SRC/dlamswlq.c create mode 100644 lapack-netlib/SRC/dlamtsqr.c create mode 100644 lapack-netlib/SRC/dlaneg.c create mode 100644 lapack-netlib/SRC/dlangb.c create mode 100644 lapack-netlib/SRC/dlange.c create mode 100644 lapack-netlib/SRC/dlangt.c create mode 100644 lapack-netlib/SRC/dlanhs.c create mode 100644 lapack-netlib/SRC/dlansb.c create mode 100644 lapack-netlib/SRC/dlansf.c create mode 100644 lapack-netlib/SRC/dlansp.c create mode 100644 lapack-netlib/SRC/dlanst.c diff --git a/lapack-netlib/SRC/dgetsqrhrt.c b/lapack-netlib/SRC/dgetsqrhrt.c new file mode 100644 index 000000000..3805c8847 --- /dev/null +++ b/lapack-netlib/SRC/dgetsqrhrt.c @@ -0,0 +1,768 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGETSQRHRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGETSQRHRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGETSQRHRT( M, N, MB1, NB1, NB2, A, LDA, T, LDT, WORK, */ +/* $ LWORK, INFO ) */ +/* IMPLICIT NONE */ + +/* INTEGER INFO, LDA, LDT, LWORK, M, N, NB1, NB2, MB1 */ +/* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGETSQRHRT computes a NB2-sized column blocked QR-factorization */ +/* > of a real M-by-N matrix A with M >= N, */ +/* > */ +/* > A = Q * R. */ +/* > */ +/* > The routine uses internally a NB1-sized column blocked and MB1-sized */ +/* > row blocked TSQR-factorization and perfors the reconstruction */ +/* > of the Householder vectors from the TSQR output. The routine also */ +/* > converts the R_tsqr factor from the TSQR-factorization output into */ +/* > the R factor that corresponds to the Householder QR-factorization, */ +/* > */ +/* > A = Q_tsqr * R_tsqr = Q * R. */ +/* > */ +/* > The output Q and R factors are stored in the same format as in DGEQRT */ +/* > (Q is in blocked compact WY-representation). See the documentation */ +/* > of DGEQRT for more details on the format. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB1 */ +/* > \verbatim */ +/* > MB1 is INTEGER */ +/* > The row block size to be used in the blocked TSQR. */ +/* > MB1 > N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB1 */ +/* > \verbatim */ +/* > NB1 is INTEGER */ +/* > The column block size to be used in the blocked TSQR. */ +/* > N >= NB1 >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB2 */ +/* > \verbatim */ +/* > NB2 is INTEGER */ +/* > The block size to be used in the blocked QR that is */ +/* > output. NB2 >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > */ +/* > On entry: an M-by-N matrix A. */ +/* > */ +/* > On exit: */ +/* > a) the elements on and above the diagonal */ +/* > of the array contain the N-by-N upper-triangular */ +/* > matrix R corresponding to the Householder QR; */ +/* > b) the elements below the diagonal represent Q by */ +/* > the columns of blocked V (compact WY-representation). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N)) */ +/* > The upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. */ +/* > LWORK >= MAX( LWT + LW1, MAX( LWT+N*N+LW2, LWT+N*N+N ) ), */ +/* > where */ +/* > NUM_ALL_ROW_BLOCKS = CEIL((M-N)/(MB1-N)), */ +/* > NB1LOCAL = MIN(NB1,N). */ +/* > LWT = NUM_ALL_ROW_BLOCKS * N * NB1LOCAL, */ +/* > LW1 = NB1LOCAL * N, */ +/* > LW2 = NB1LOCAL * MAX( NB1LOCAL, ( N - NB1LOCAL ) ), */ +/* > 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. */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2020, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dgetsqrhrt_(integer *m, integer *n, integer *mb1, + integer *nb1, integer *nb2, doublereal *a, integer *lda, doublereal * + t, integer *ldt, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer ldwt, lworkopt, i__, j; + extern /* Subroutine */ int dorgtsqr_row_(integer *, integer *, integer * + , integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *); + integer iinfo; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dorhr_col_(integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + logical lquery; + integer lw1, lw2, num_all_row_blocks__, lwt; + extern /* Subroutine */ int dlatsqr_(integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *); + integer nb1local, nb2local; + + +/* -- LAPACK computational routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *m < *n) { + *info = -2; + } else if (*mb1 <= *n) { + *info = -3; + } else if (*nb1 < 1) { + *info = -4; + } else if (*nb2 < 1) { + *info = -5; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = f2cmin(*nb2,*n); + if (*ldt < f2cmax(i__1,i__2)) { + *info = -9; + } else { + +/* Test the input LWORK for the dimension of the array WORK. */ +/* This workspace is used to store array: */ +/* a) Matrix T and WORK for DLATSQR; */ +/* b) N-by-N upper-triangular factor R_tsqr; */ +/* c) Matrix T and array WORK for DORGTSQR_ROW; */ +/* d) Diagonal D for DORHR_COL. */ + + if (*lwork < *n * *n + 1 && ! lquery) { + *info = -11; + } else { + +/* Set block size for column blocks */ + + nb1local = f2cmin(*nb1,*n); + +/* Computing MAX */ + d__3 = (doublereal) (*m - *n) / (doublereal) (*mb1 - *n) + + .5f; + d__1 = 1., d__2 = d_int(&d__3); + num_all_row_blocks__ = (integer) f2cmax(d__1,d__2); + +/* Length and leading dimension of WORK array to place */ +/* T array in TSQR. */ + + lwt = num_all_row_blocks__ * *n * nb1local; + ldwt = nb1local; + +/* Length of TSQR work array */ + + lw1 = nb1local * *n; + +/* Length of DORGTSQR_ROW work array. */ + +/* Computing MAX */ + i__1 = nb1local, i__2 = *n - nb1local; + lw2 = nb1local * f2cmax(i__1,i__2); + +/* Computing MAX */ +/* Computing MAX */ + i__3 = lwt + *n * *n + lw2, i__4 = lwt + *n * *n + *n; + i__1 = lwt + lw1, i__2 = f2cmax(i__3,i__4); + lworkopt = f2cmax(i__1,i__2); + + if (*lwork < f2cmax(1,lworkopt) && ! lquery) { + *info = -11; + } + + } + } + } + +/* Handle error in the input parameters and return workspace query. */ + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGETSQRHRT", &i__1, (ftnlen)10); + return 0; + } else if (lquery) { + work[1] = (doublereal) lworkopt; + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + work[1] = (doublereal) lworkopt; + return 0; + } + + nb2local = f2cmin(*nb2,*n); + + +/* (1) Perform TSQR-factorization of the M-by-N matrix A. */ + + dlatsqr_(m, n, mb1, &nb1local, &a[a_offset], lda, &work[1], &ldwt, &work[ + lwt + 1], &lw1, &iinfo); + +/* (2) Copy the factor R_tsqr stored in the upper-triangular part */ +/* of A into the square matrix in the work array */ +/* WORK(LWT+1:LWT+N*N) column-by-column. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dcopy_(&j, &a[j * a_dim1 + 1], &c__1, &work[lwt + *n * (j - 1) + 1], & + c__1); + } + +/* (3) Generate a M-by-N matrix Q with orthonormal columns from */ +/* the result stored below the diagonal in the array A in place. */ + + dorgtsqr_row_(m, n, mb1, &nb1local, &a[a_offset], lda, &work[1], &ldwt, & + work[lwt + *n * *n + 1], &lw2, &iinfo); + +/* (4) Perform the reconstruction of Householder vectors from */ +/* the matrix Q (stored in A) in place. */ + + dorhr_col_(m, n, &nb2local, &a[a_offset], lda, &t[t_offset], ldt, &work[ + lwt + *n * *n + 1], &iinfo); + +/* (5) Copy the factor R_tsqr stored in the square matrix in the */ +/* work array WORK(LWT+1:LWT+N*N) into the upper-triangular */ +/* part of A. */ + +/* (6) Compute from R_tsqr the factor R_hr corresponding to */ +/* the reconstructed Householder vectors, i.e. R_hr = S * R_tsqr. */ +/* This multiplication by the sign matrix S on the left means */ +/* changing the sign of I-th row of the matrix R_tsqr according */ +/* to sign of the I-th diagonal element DIAG(I) of the matrix S. */ +/* DIAG is stored in WORK( LWT+N*N+1 ) from the DORHR_COL output. */ + +/* (5) and (6) can be combined in a single loop, so the rows in A */ +/* are accessed only once. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (work[lwt + *n * *n + i__] == -1.) { + i__2 = *n; + for (j = i__; j <= i__2; ++j) { + a[i__ + j * a_dim1] = work[lwt + *n * (j - 1) + i__] * -1.; + } + } else { + i__2 = *n - i__ + 1; + dcopy_(&i__2, &work[lwt + *n * (i__ - 1) + i__], n, &a[i__ + i__ * + a_dim1], lda); + } + } + + work[1] = (doublereal) lworkopt; + return 0; + +/* End of DGETSQRHRT */ + +} /* dgetsqrhrt_ */ + diff --git a/lapack-netlib/SRC/dggbak.c b/lapack-netlib/SRC/dggbak.c new file mode 100644 index 000000000..946099193 --- /dev/null +++ b/lapack-netlib/SRC/dggbak.c @@ -0,0 +1,722 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGGBAK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGBAK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, */ +/* LDV, INFO ) */ + +/* CHARACTER JOB, SIDE */ +/* INTEGER IHI, ILO, INFO, LDV, M, N */ +/* DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGBAK forms the right or left eigenvectors of a real generalized */ +/* > eigenvalue problem A*x = lambda*B*x, by backward transformation on */ +/* > the computed eigenvectors of the balanced pair of matrices output by */ +/* > DGGBAL. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies the type of backward transformation required: */ +/* > = 'N': do nothing, return immediately; */ +/* > = 'P': do backward transformation for permutation only; */ +/* > = 'S': do backward transformation for scaling only; */ +/* > = 'B': do backward transformations for both permutation and */ +/* > scaling. */ +/* > JOB must be the same as the argument JOB supplied to DGGBAL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': V contains right eigenvectors; */ +/* > = 'L': V contains left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows of the matrix V. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > The integers ILO and IHI determined by DGGBAL. */ +/* > 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LSCALE */ +/* > \verbatim */ +/* > LSCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and/or scaling factors applied */ +/* > to the left side of A and B, as returned by DGGBAL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSCALE */ +/* > \verbatim */ +/* > RSCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and/or scaling factors applied */ +/* > to the right side of A and B, as returned by DGGBAL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns of the matrix V. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,M) */ +/* > On entry, the matrix of right or left eigenvectors to be */ +/* > transformed, as returned by DTGEVC. */ +/* > On exit, V is overwritten by the transformed eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the matrix V. LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGBcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > See R.C. Ward, Balancing the generalized eigenvalue problem, */ +/* > SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggbak_(char *job, char *side, integer *n, integer *ilo, + integer *ihi, doublereal *lscale, doublereal *rscale, integer *m, + doublereal *v, integer *ldv, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, i__1; + + /* Local variables */ + integer i__, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical leftv; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical rightv; + + +/* -- 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 */ + --lscale; + --rscale; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + + /* Function Body */ + rightv = lsame_(side, "R"); + leftv = lsame_(side, "L"); + + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (! rightv && ! leftv) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1) { + *info = -4; + } else if (*n == 0 && *ihi == 0 && *ilo != 1) { + *info = -4; + } else if (*n > 0 && (*ihi < *ilo || *ihi > f2cmax(1,*n))) { + *info = -5; + } else if (*n == 0 && *ilo == 1 && *ihi != 0) { + *info = -5; + } else if (*m < 0) { + *info = -8; + } else if (*ldv < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGBAK", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*m == 0) { + return 0; + } + if (lsame_(job, "N")) { + return 0; + } + + if (*ilo == *ihi) { + goto L30; + } + +/* Backward balance */ + + if (lsame_(job, "S") || lsame_(job, "B")) { + +/* Backward transformation on right eigenvectors */ + + if (rightv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + dscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv); +/* L10: */ + } + } + +/* Backward transformation on left eigenvectors */ + + if (leftv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + dscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv); +/* L20: */ + } + } + } + +/* Backward permutation */ + +L30: + if (lsame_(job, "P") || lsame_(job, "B")) { + +/* Backward permutation on right eigenvectors */ + + if (rightv) { + if (*ilo == 1) { + goto L50; + } + + for (i__ = *ilo - 1; i__ >= 1; --i__) { + k = (integer) rscale[i__]; + if (k == i__) { + goto L40; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L40: + ; + } + +L50: + if (*ihi == *n) { + goto L70; + } + i__1 = *n; + for (i__ = *ihi + 1; i__ <= i__1; ++i__) { + k = (integer) rscale[i__]; + if (k == i__) { + goto L60; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L60: + ; + } + } + +/* Backward permutation on left eigenvectors */ + +L70: + if (leftv) { + if (*ilo == 1) { + goto L90; + } + for (i__ = *ilo - 1; i__ >= 1; --i__) { + k = (integer) lscale[i__]; + if (k == i__) { + goto L80; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L80: + ; + } + +L90: + if (*ihi == *n) { + goto L110; + } + i__1 = *n; + for (i__ = *ihi + 1; i__ <= i__1; ++i__) { + k = (integer) lscale[i__]; + if (k == i__) { + goto L100; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L100: + ; + } + } + } + +L110: + + return 0; + +/* End of DGGBAK */ + +} /* dggbak_ */ + diff --git a/lapack-netlib/SRC/dggbal.c b/lapack-netlib/SRC/dggbal.c new file mode 100644 index 000000000..9f56b3e42 --- /dev/null +++ b/lapack-netlib/SRC/dggbal.c @@ -0,0 +1,1071 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGGBAL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGBAL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, */ +/* RSCALE, WORK, INFO ) */ + +/* CHARACTER JOB */ +/* INTEGER IHI, ILO, INFO, LDA, LDB, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), */ +/* $ RSCALE( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGBAL balances a pair of general real matrices (A,B). This */ +/* > involves, first, permuting A and B by similarity transformations to */ +/* > isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */ +/* > elements on the diagonal; and second, applying a diagonal similarity */ +/* > transformation to rows and columns ILO to IHI to make the rows */ +/* > and columns as close in norm as possible. Both steps are optional. */ +/* > */ +/* > Balancing may reduce the 1-norm of the matrices, and improve the */ +/* > accuracy of the computed eigenvalues and/or eigenvectors in the */ +/* > generalized eigenvalue problem A*x = lambda*B*x. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies the operations to be performed on A and B: */ +/* > = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */ +/* > and RSCALE(I) = 1.0 for i = 1,...,N. */ +/* > = 'P': permute only; */ +/* > = 'S': scale only; */ +/* > = 'B': both permute and scale. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the input matrix A. */ +/* > On exit, A is overwritten by the balanced matrix. */ +/* > If JOB = 'N', A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the input matrix B. */ +/* > On exit, B is overwritten by the balanced matrix. */ +/* > If JOB = 'N', B is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > ILO and IHI are set to integers such that on exit */ +/* > A(i,j) = 0 and B(i,j) = 0 if i > j and */ +/* > j = 1,...,ILO-1 or i = IHI+1,...,N. */ +/* > If JOB = 'N' or 'S', ILO = 1 and IHI = N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] LSCALE */ +/* > \verbatim */ +/* > LSCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and scaling factors applied */ +/* > to the left side of A and B. If P(j) is the index of the */ +/* > row interchanged with row j, and D(j) */ +/* > is the scaling factor applied to row j, then */ +/* > LSCALE(j) = P(j) for J = 1,...,ILO-1 */ +/* > = D(j) for J = ILO,...,IHI */ +/* > = P(j) for J = IHI+1,...,N. */ +/* > The order in which the interchanges are made is N to IHI+1, */ +/* > then 1 to ILO-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RSCALE */ +/* > \verbatim */ +/* > RSCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and scaling factors applied */ +/* > to the right side of A and B. If P(j) is the index of the */ +/* > column interchanged with column j, and D(j) */ +/* > is the scaling factor applied to column j, then */ +/* > LSCALE(j) = P(j) for J = 1,...,ILO-1 */ +/* > = D(j) for J = ILO,...,IHI */ +/* > = P(j) for J = IHI+1,...,N. */ +/* > The order in which the interchanges are made is N to IHI+1, */ +/* > then 1 to ILO-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (lwork) */ +/* > lwork must be at least f2cmax(1,6*N) when JOB = 'S' or 'B', and */ +/* > at least 1 when JOB = 'N' or 'P'. */ +/* > \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 doubleGBcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > See R.C. WARD, Balancing the generalized eigenvalue problem, */ +/* > SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggbal_(char *job, integer *n, doublereal *a, integer * + lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi, + doublereal *lscale, doublereal *rscale, doublereal *work, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer lcab; + doublereal beta, coef; + integer irab, lrab; + doublereal basl, cmax; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal coef2, coef5; + integer i__, j, k, l, m; + doublereal gamma, t, alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal sfmin, sfmax; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer iflow; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + integer kount, jc; + doublereal ta, tb, tc; + extern doublereal dlamch_(char *); + integer ir, it; + doublereal ew; + integer nr; + doublereal pgamma; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer lsfmin, lsfmax, ip1, jp1, lm1; + doublereal cab, rab, ewc, cor, sum; + integer nrp2, icab; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --lscale; + --rscale; + --work; + + /* Function Body */ + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldb < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGBAL", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *ilo = 1; + *ihi = *n; + return 0; + } + + if (*n == 1) { + *ilo = 1; + *ihi = *n; + lscale[1] = 1.; + rscale[1] = 1.; + return 0; + } + + if (lsame_(job, "N")) { + *ilo = 1; + *ihi = *n; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + lscale[i__] = 1.; + rscale[i__] = 1.; +/* L10: */ + } + return 0; + } + + k = 1; + l = *n; + if (lsame_(job, "S")) { + goto L190; + } + + goto L30; + +/* Permute the matrices A and B to isolate the eigenvalues. */ + +/* Find row with one nonzero in columns 1 through L */ + +L20: + l = lm1; + if (l != 1) { + goto L30; + } + + rscale[1] = 1.; + lscale[1] = 1.; + goto L190; + +L30: + lm1 = l - 1; + for (i__ = l; i__ >= 1; --i__) { + i__1 = lm1; + for (j = 1; j <= i__1; ++j) { + jp1 = j + 1; + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L50; + } +/* L40: */ + } + j = l; + goto L70; + +L50: + i__1 = l; + for (j = jp1; j <= i__1; ++j) { + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L80; + } +/* L60: */ + } + j = jp1 - 1; + +L70: + m = l; + iflow = 1; + goto L160; +L80: + ; + } + goto L100; + +/* Find column with one nonzero in rows K through N */ + +L90: + ++k; + +L100: + i__1 = l; + for (j = k; j <= i__1; ++j) { + i__2 = lm1; + for (i__ = k; i__ <= i__2; ++i__) { + ip1 = i__ + 1; + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L120; + } +/* L110: */ + } + i__ = l; + goto L140; +L120: + i__2 = l; + for (i__ = ip1; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L150; + } +/* L130: */ + } + i__ = ip1 - 1; +L140: + m = k; + iflow = 2; + goto L160; +L150: + ; + } + goto L190; + +/* Permute rows M and I */ + +L160: + lscale[m] = (doublereal) i__; + if (i__ == m) { + goto L170; + } + i__1 = *n - k + 1; + dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda); + i__1 = *n - k + 1; + dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb); + +/* Permute columns M and J */ + +L170: + rscale[m] = (doublereal) j; + if (j == m) { + goto L180; + } + dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); + dswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1); + +L180: + switch (iflow) { + case 1: goto L20; + case 2: goto L90; + } + +L190: + *ilo = k; + *ihi = l; + + if (lsame_(job, "P")) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + lscale[i__] = 1.; + rscale[i__] = 1.; +/* L195: */ + } + return 0; + } + + if (*ilo == *ihi) { + return 0; + } + +/* Balance the submatrix in rows ILO to IHI. */ + + nr = *ihi - *ilo + 1; + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + rscale[i__] = 0.; + lscale[i__] = 0.; + + work[i__] = 0.; + work[i__ + *n] = 0.; + work[i__ + (*n << 1)] = 0.; + work[i__ + *n * 3] = 0.; + work[i__ + (*n << 2)] = 0.; + work[i__ + *n * 5] = 0.; +/* L200: */ + } + +/* Compute right side vector in resulting linear equations */ + + basl = d_lg10(&c_b35); + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + i__2 = *ihi; + for (j = *ilo; j <= i__2; ++j) { + tb = b[i__ + j * b_dim1]; + ta = a[i__ + j * a_dim1]; + if (ta == 0.) { + goto L210; + } + d__1 = abs(ta); + ta = d_lg10(&d__1) / basl; +L210: + if (tb == 0.) { + goto L220; + } + d__1 = abs(tb); + tb = d_lg10(&d__1) / basl; +L220: + work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb; + work[j + *n * 5] = work[j + *n * 5] - ta - tb; +/* L230: */ + } +/* L240: */ + } + + coef = 1. / (doublereal) (nr << 1); + coef2 = coef * coef; + coef5 = coef2 * .5; + nrp2 = nr + 2; + beta = 0.; + it = 1; + +/* Start generalized conjugate gradient iteration */ + +L250: + + gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)] + , &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + * + n * 5], &c__1); + + ew = 0.; + ewc = 0.; + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + ew += work[i__ + (*n << 2)]; + ewc += work[i__ + *n * 5]; +/* L260: */ + } + +/* Computing 2nd power */ + d__1 = ew; +/* Computing 2nd power */ + d__2 = ewc; +/* Computing 2nd power */ + d__3 = ew - ewc; + gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * ( + d__3 * d__3); + if (gamma == 0.) { + goto L350; + } + if (it != 1) { + beta = gamma / pgamma; + } + t = coef5 * (ewc - ew * 3.); + tc = coef5 * (ew - ewc * 3.); + + dscal_(&nr, &beta, &work[*ilo], &c__1); + dscal_(&nr, &beta, &work[*ilo + *n], &c__1); + + daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], & + c__1); + daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1); + + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + work[i__] += tc; + work[i__ + *n] += t; +/* L270: */ + } + +/* Apply matrix to vector */ + + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + kount = 0; + sum = 0.; + i__2 = *ihi; + for (j = *ilo; j <= i__2; ++j) { + if (a[i__ + j * a_dim1] == 0.) { + goto L280; + } + ++kount; + sum += work[j]; +L280: + if (b[i__ + j * b_dim1] == 0.) { + goto L290; + } + ++kount; + sum += work[j]; +L290: + ; + } + work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum; +/* L300: */ + } + + i__1 = *ihi; + for (j = *ilo; j <= i__1; ++j) { + kount = 0; + sum = 0.; + i__2 = *ihi; + for (i__ = *ilo; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] == 0.) { + goto L310; + } + ++kount; + sum += work[i__ + *n]; +L310: + if (b[i__ + j * b_dim1] == 0.) { + goto L320; + } + ++kount; + sum += work[i__ + *n]; +L320: + ; + } + work[j + *n * 3] = (doublereal) kount * work[j] + sum; +/* L330: */ + } + + sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1) + + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1); + alpha = gamma / sum; + +/* Determine correction to current iteration */ + + cmax = 0.; + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + cor = alpha * work[i__ + *n]; + if (abs(cor) > cmax) { + cmax = abs(cor); + } + lscale[i__] += cor; + cor = alpha * work[i__]; + if (abs(cor) > cmax) { + cmax = abs(cor); + } + rscale[i__] += cor; +/* L340: */ + } + if (cmax < .5) { + goto L350; + } + + d__1 = -alpha; + daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)] + , &c__1); + d__1 = -alpha; + daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], & + c__1); + + pgamma = gamma; + ++it; + if (it <= nrp2) { + goto L250; + } + +/* End generalized conjugate gradient iteration */ + +L350: + sfmin = dlamch_("S"); + sfmax = 1. / sfmin; + lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.); + lsfmax = (integer) (d_lg10(&sfmax) / basl); + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + i__2 = *n - *ilo + 1; + irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda); + rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], abs(d__1)); + i__2 = *n - *ilo + 1; + irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb); +/* Computing MAX */ + d__2 = rab, d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], abs( + d__1)); + rab = f2cmax(d__2,d__3); + d__1 = rab + sfmin; + lrab = (integer) (d_lg10(&d__1) / basl + 1.); + ir = (integer) (lscale[i__] + d_sign(&c_b71, &lscale[i__])); +/* Computing MIN */ + i__2 = f2cmax(ir,lsfmin), i__2 = f2cmin(i__2,lsfmax), i__3 = lsfmax - lrab; + ir = f2cmin(i__2,i__3); + lscale[i__] = pow_di(&c_b35, &ir); + icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1); + cab = (d__1 = a[icab + i__ * a_dim1], abs(d__1)); + icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1); +/* Computing MAX */ + d__2 = cab, d__3 = (d__1 = b[icab + i__ * b_dim1], abs(d__1)); + cab = f2cmax(d__2,d__3); + d__1 = cab + sfmin; + lcab = (integer) (d_lg10(&d__1) / basl + 1.); + jc = (integer) (rscale[i__] + d_sign(&c_b71, &rscale[i__])); +/* Computing MIN */ + i__2 = f2cmax(jc,lsfmin), i__2 = f2cmin(i__2,lsfmax), i__3 = lsfmax - lcab; + jc = f2cmin(i__2,i__3); + rscale[i__] = pow_di(&c_b35, &jc); +/* L360: */ + } + +/* Row scaling of matrices A and B */ + + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + i__2 = *n - *ilo + 1; + dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda); + i__2 = *n - *ilo + 1; + dscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb); +/* L370: */ + } + +/* Column scaling of matrices A and B */ + + i__1 = *ihi; + for (j = *ilo; j <= i__1; ++j) { + dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1); + dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1); +/* L380: */ + } + + return 0; + +/* End of DGGBAL */ + +} /* dggbal_ */ + diff --git a/lapack-netlib/SRC/dgges.c b/lapack-netlib/SRC/dgges.c new file mode 100644 index 000000000..90ff86599 --- /dev/null +++ b/lapack-netlib/SRC/dgges.c @@ -0,0 +1,1167 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors f +or GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGES + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, */ +/* SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, */ +/* LDVSR, WORK, LWORK, BWORK, INFO ) */ + +/* CHARACTER JOBVSL, JOBVSR, SORT */ +/* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM */ +/* LOGICAL BWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), */ +/* $ VSR( LDVSR, * ), WORK( * ) */ +/* LOGICAL SELCTG */ +/* EXTERNAL SELCTG */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), */ +/* > the generalized eigenvalues, the generalized real Schur form (S,T), */ +/* > optionally, the left and/or right matrices of Schur vectors (VSL and */ +/* > VSR). This gives the generalized Schur factorization */ +/* > */ +/* > (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) */ +/* > */ +/* > Optionally, it also orders the eigenvalues so that a selected cluster */ +/* > of eigenvalues appears in the leading diagonal blocks of the upper */ +/* > quasi-triangular matrix S and the upper triangular matrix T.The */ +/* > leading columns of VSL and VSR then form an orthonormal basis for the */ +/* > corresponding left and right eigenspaces (deflating subspaces). */ +/* > */ +/* > (If only the generalized eigenvalues are needed, use the driver */ +/* > DGGEV instead, which is faster.) */ +/* > */ +/* > A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */ +/* > or a ratio alpha/beta = w, such that A - w*B is singular. It is */ +/* > usually represented as the pair (alpha,beta), as there is a */ +/* > reasonable interpretation for beta=0 or both being zero. */ +/* > */ +/* > A pair of matrices (S,T) is in generalized real Schur form if T is */ +/* > upper triangular with non-negative diagonal and S is block upper */ +/* > triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */ +/* > to real generalized eigenvalues, while 2-by-2 blocks of S will be */ +/* > "standardized" by making the corresponding elements of T have the */ +/* > form: */ +/* > [ a 0 ] */ +/* > [ 0 b ] */ +/* > */ +/* > and the pair of corresponding 2-by-2 blocks in S and T will have a */ +/* > complex conjugate pair of generalized eigenvalues. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVSL */ +/* > \verbatim */ +/* > JOBVSL is CHARACTER*1 */ +/* > = 'N': do not compute the left Schur vectors; */ +/* > = 'V': compute the left Schur vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVSR */ +/* > \verbatim */ +/* > JOBVSR is CHARACTER*1 */ +/* > = 'N': do not compute the right Schur vectors; */ +/* > = 'V': compute the right Schur vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SORT */ +/* > \verbatim */ +/* > SORT is CHARACTER*1 */ +/* > Specifies whether or not to order the eigenvalues on the */ +/* > diagonal of the generalized Schur form. */ +/* > = 'N': Eigenvalues are not ordered; */ +/* > = 'S': Eigenvalues are ordered (see SELCTG); */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELCTG */ +/* > \verbatim */ +/* > SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments */ +/* > SELCTG must be declared EXTERNAL in the calling subroutine. */ +/* > If SORT = 'N', SELCTG is not referenced. */ +/* > If SORT = 'S', SELCTG is used to select eigenvalues to sort */ +/* > to the top left of the Schur form. */ +/* > An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */ +/* > SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */ +/* > one of a complex conjugate pair of eigenvalues is selected, */ +/* > then both complex eigenvalues are selected. */ +/* > */ +/* > Note that in the ill-conditioned case, a selected complex */ +/* > eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), */ +/* > BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 */ +/* > in this case. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VSL, and VSR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the first of the pair of matrices. */ +/* > On exit, A has been overwritten by its generalized Schur */ +/* > form S. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the second of the pair of matrices. */ +/* > On exit, B has been overwritten by its generalized Schur */ +/* > form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SDIM */ +/* > \verbatim */ +/* > SDIM is INTEGER */ +/* > If SORT = 'N', SDIM = 0. */ +/* > If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ +/* > for which SELCTG is true. (Complex conjugate pairs for which */ +/* > SELCTG is true for either eigenvalue count as 2.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, */ +/* > and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* > form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* > the real Schur form of (A,B) were further reduced to */ +/* > triangular form using 2-by-2 complex unitary transformations. */ +/* > If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* > positive, then the j-th and (j+1)-st eigenvalues are a */ +/* > complex conjugate pair, with ALPHAI(j+1) negative. */ +/* > */ +/* > Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* > may easily over- or underflow, and BETA(j) may even be zero. */ +/* > Thus, the user should avoid naively computing the ratio. */ +/* > However, ALPHAR and ALPHAI will be always less than and */ +/* > usually comparable with norm(A) in magnitude, and BETA always */ +/* > less than and usually comparable with norm(B). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSL */ +/* > \verbatim */ +/* > VSL is DOUBLE PRECISION array, dimension (LDVSL,N) */ +/* > If JOBVSL = 'V', VSL will contain the left Schur vectors. */ +/* > Not referenced if JOBVSL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSL */ +/* > \verbatim */ +/* > LDVSL is INTEGER */ +/* > The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* > if JOBVSL = 'V', LDVSL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSR */ +/* > \verbatim */ +/* > VSR is DOUBLE PRECISION array, dimension (LDVSR,N) */ +/* > If JOBVSR = 'V', VSR will contain the right Schur vectors. */ +/* > Not referenced if JOBVSR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSR */ +/* > \verbatim */ +/* > LDVSR is INTEGER */ +/* > The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* > if JOBVSR = 'V', LDVSR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N = 0, LWORK >= 1, else LWORK >= 8*N+16. */ +/* > For good performance , LWORK must generally be larger. */ +/* > */ +/* > 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] BWORK */ +/* > \verbatim */ +/* > BWORK is LOGICAL array, dimension (N) */ +/* > Not referenced if SORT = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. (A,B) are not in Schur */ +/* > form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* > be correct for j=INFO+1,...,N. */ +/* > > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* > =N+2: after reordering, roundoff changed values of */ +/* > some complex eigenvalues so that leading */ +/* > eigenvalues in the Generalized Schur form no */ +/* > longer satisfy SELCTG=.TRUE. This could also */ +/* > be caused due to scaling. */ +/* > =N+3: reordering failed in DTGSEN. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp + selctg, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai, + doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr, + integer *ldvsr, doublereal *work, integer *lwork, logical *bwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal anrm, bnrm; + integer idum[1], ierr, itau, iwrk; + doublereal pvsl, pvsr; + integer i__; + extern logical lsame_(char *, char *); + integer ileft, icols; + logical cursl, ilvsl, ilvsr; + integer irows; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dggbak_( + char *, char *, integer *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer + *, doublereal *, integer *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *); + logical lst2sl; + extern doublereal dlamch_(char *); + integer ip; + extern doublereal dlange_(char *, integer *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + doublereal safmax; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), dtgsen_(integer *, logical *, + logical *, logical *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, integer *, integer *); + integer ijobvl, iright; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ijobvr; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal anrmto, bnrmto; + logical lastsl; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer minwrk, maxwrk; + doublereal smlnum; + logical wantst, lquery; + doublereal dif[2]; + integer ihi, ilo; + doublereal eps; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1 * 1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1 * 1; + vsr -= vsr_offset; + --work; + --bwork; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = FALSE_; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = TRUE_; + } else { + ijobvl = -1; + ilvsl = FALSE_; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = FALSE_; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = TRUE_; + } else { + ijobvr = -1; + ilvsr = FALSE_; + } + + wantst = lsame_(sort, "S"); + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -3; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -15; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -17; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + if (*n > 0) { +/* Computing MAX */ + i__1 = *n << 3, i__2 = *n * 6 + 16; + minwrk = f2cmax(i__1,i__2); + maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & + c__1, n, &c__0, (ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR", + " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + if (ilvsl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR" + "GQR", " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + } + } else { + minwrk = 1; + maxwrk = 1; + } + work[1] = (doublereal) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -19; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGES ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + safmin = dlamch_("S"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + smlnum = sqrt(safmin) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ +/* (Workspace: need 6*N + 2*N space for storing balancing factors) */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB) */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VSL */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvsl) { + dlaset_("Full", n, n, &c_b38, &c_b39, &vsl[vsl_offset], ldvsl); + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ + ilo + 1 + ilo * vsl_dim1], ldvsl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VSR */ + + if (ilvsr) { + dlaset_("Full", n, n, &c_b38, &c_b39, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr); + +/* Perform QZ algorithm, computing Schur vectors if desired */ +/* (Workspace: need N) */ + + iwrk = itau; + i__1 = *lwork + 1 - iwrk; + dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] + , ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L50; + } + +/* Sort eigenvalues ALPHA/BETA if desired */ +/* (Workspace: need 4*N+16 ) */ + + *sdim = 0; + if (wantst) { + +/* Undo scaling on eigenvalues before SELCTGing */ + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], + n, &ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], + n, &ierr); + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, + &ierr); + } + +/* Select eigenvalues */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); +/* L10: */ + } + + i__1 = *lwork - iwrk + 1; + dtgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ + vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, & + pvsr, dif, &work[iwrk], &i__1, idum, &c__1, &ierr); + if (ierr == 1) { + *info = *n + 3; + } + + } + +/* Apply back-permutation to VSL and VSR */ +/* (Workspace: none needed) */ + + if (ilvsl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &ierr); + } + + if (ilvsr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &ierr); + } + +/* Check if unscaling would cause over/underflow, if so, rescale */ +/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */ +/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */ + + if (ilascl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[ + i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__], + abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } else if (alphai[i__] / safmax > anrmto / anrm || safmin / + alphai[i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[ + i__], abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L20: */ + } + } + + if (ilbscl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__] + > bnrm / bnrmto) { + work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs( + d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L30: */ + } + } + +/* Undo scaling */ + + if (ilascl) { + dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + ierr); + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + if (wantst) { + +/* Check if reordering is correct */ + + lastsl = TRUE_; + lst2sl = TRUE_; + *sdim = 0; + ip = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); + if (alphai[i__] == 0.) { + if (cursl) { + ++(*sdim); + } + ip = 0; + if (cursl && ! lastsl) { + *info = *n + 2; + } + } else { + if (ip == 1) { + +/* Last eigenvalue of conjugate pair */ + + cursl = cursl || lastsl; + lastsl = cursl; + if (cursl) { + *sdim += 2; + } + ip = -1; + if (cursl && ! lst2sl) { + *info = *n + 2; + } + } else { + +/* First eigenvalue of conjugate pair */ + + ip = 1; + } + } + lst2sl = lastsl; + lastsl = cursl; +/* L40: */ + } + + } + +L50: + + work[1] = (doublereal) maxwrk; + + return 0; + +/* End of DGGES */ + +} /* dgges_ */ + diff --git a/lapack-netlib/SRC/dgges3.c b/lapack-netlib/SRC/dgges3.c new file mode 100644 index 000000000..3b18db557 --- /dev/null +++ b/lapack-netlib/SRC/dgges3.c @@ -0,0 +1,1169 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors +for GE matrices (blocked algorithm) */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGES3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, */ +/* SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, */ +/* LDVSR, WORK, LWORK, BWORK, INFO ) */ + +/* CHARACTER JOBVSL, JOBVSR, SORT */ +/* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM */ +/* LOGICAL BWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), */ +/* $ VSR( LDVSR, * ), WORK( * ) */ +/* LOGICAL SELCTG */ +/* EXTERNAL SELCTG */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B), */ +/* > the generalized eigenvalues, the generalized real Schur form (S,T), */ +/* > optionally, the left and/or right matrices of Schur vectors (VSL and */ +/* > VSR). This gives the generalized Schur factorization */ +/* > */ +/* > (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) */ +/* > */ +/* > Optionally, it also orders the eigenvalues so that a selected cluster */ +/* > of eigenvalues appears in the leading diagonal blocks of the upper */ +/* > quasi-triangular matrix S and the upper triangular matrix T.The */ +/* > leading columns of VSL and VSR then form an orthonormal basis for the */ +/* > corresponding left and right eigenspaces (deflating subspaces). */ +/* > */ +/* > (If only the generalized eigenvalues are needed, use the driver */ +/* > DGGEV instead, which is faster.) */ +/* > */ +/* > A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */ +/* > or a ratio alpha/beta = w, such that A - w*B is singular. It is */ +/* > usually represented as the pair (alpha,beta), as there is a */ +/* > reasonable interpretation for beta=0 or both being zero. */ +/* > */ +/* > A pair of matrices (S,T) is in generalized real Schur form if T is */ +/* > upper triangular with non-negative diagonal and S is block upper */ +/* > triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */ +/* > to real generalized eigenvalues, while 2-by-2 blocks of S will be */ +/* > "standardized" by making the corresponding elements of T have the */ +/* > form: */ +/* > [ a 0 ] */ +/* > [ 0 b ] */ +/* > */ +/* > and the pair of corresponding 2-by-2 blocks in S and T will have a */ +/* > complex conjugate pair of generalized eigenvalues. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVSL */ +/* > \verbatim */ +/* > JOBVSL is CHARACTER*1 */ +/* > = 'N': do not compute the left Schur vectors; */ +/* > = 'V': compute the left Schur vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVSR */ +/* > \verbatim */ +/* > JOBVSR is CHARACTER*1 */ +/* > = 'N': do not compute the right Schur vectors; */ +/* > = 'V': compute the right Schur vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SORT */ +/* > \verbatim */ +/* > SORT is CHARACTER*1 */ +/* > Specifies whether or not to order the eigenvalues on the */ +/* > diagonal of the generalized Schur form. */ +/* > = 'N': Eigenvalues are not ordered; */ +/* > = 'S': Eigenvalues are ordered (see SELCTG); */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELCTG */ +/* > \verbatim */ +/* > SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments */ +/* > SELCTG must be declared EXTERNAL in the calling subroutine. */ +/* > If SORT = 'N', SELCTG is not referenced. */ +/* > If SORT = 'S', SELCTG is used to select eigenvalues to sort */ +/* > to the top left of the Schur form. */ +/* > An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */ +/* > SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */ +/* > one of a complex conjugate pair of eigenvalues is selected, */ +/* > then both complex eigenvalues are selected. */ +/* > */ +/* > Note that in the ill-conditioned case, a selected complex */ +/* > eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), */ +/* > BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 */ +/* > in this case. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VSL, and VSR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the first of the pair of matrices. */ +/* > On exit, A has been overwritten by its generalized Schur */ +/* > form S. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the second of the pair of matrices. */ +/* > On exit, B has been overwritten by its generalized Schur */ +/* > form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SDIM */ +/* > \verbatim */ +/* > SDIM is INTEGER */ +/* > If SORT = 'N', SDIM = 0. */ +/* > If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ +/* > for which SELCTG is true. (Complex conjugate pairs for which */ +/* > SELCTG is true for either eigenvalue count as 2.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, */ +/* > and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* > form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* > the real Schur form of (A,B) were further reduced to */ +/* > triangular form using 2-by-2 complex unitary transformations. */ +/* > If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* > positive, then the j-th and (j+1)-st eigenvalues are a */ +/* > complex conjugate pair, with ALPHAI(j+1) negative. */ +/* > */ +/* > Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* > may easily over- or underflow, and BETA(j) may even be zero. */ +/* > Thus, the user should avoid naively computing the ratio. */ +/* > However, ALPHAR and ALPHAI will be always less than and */ +/* > usually comparable with norm(A) in magnitude, and BETA always */ +/* > less than and usually comparable with norm(B). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSL */ +/* > \verbatim */ +/* > VSL is DOUBLE PRECISION array, dimension (LDVSL,N) */ +/* > If JOBVSL = 'V', VSL will contain the left Schur vectors. */ +/* > Not referenced if JOBVSL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSL */ +/* > \verbatim */ +/* > LDVSL is INTEGER */ +/* > The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* > if JOBVSL = 'V', LDVSL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSR */ +/* > \verbatim */ +/* > VSR is DOUBLE PRECISION array, dimension (LDVSR,N) */ +/* > If JOBVSR = 'V', VSR will contain the right Schur vectors. */ +/* > Not referenced if JOBVSR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSR */ +/* > \verbatim */ +/* > LDVSR is INTEGER */ +/* > The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* > if JOBVSR = 'V', LDVSR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > */ +/* > If 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] BWORK */ +/* > \verbatim */ +/* > BWORK is LOGICAL array, dimension (N) */ +/* > Not referenced if SORT = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. (A,B) are not in Schur */ +/* > form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* > be correct for j=INFO+1,...,N. */ +/* > > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* > =N+2: after reordering, roundoff changed values of */ +/* > some complex eigenvalues so that leading */ +/* > eigenvalues in the Generalized Schur form no */ +/* > longer satisfy SELCTG=.TRUE. This could also */ +/* > be caused due to scaling. */ +/* > =N+3: reordering failed in DTGSEN. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date January 2015 */ + +/* > \ingroup doubleGEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dgges3_(char *jobvsl, char *jobvsr, char *sort, L_fp + selctg, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai, + doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr, + integer *ldvsr, doublereal *work, integer *lwork, logical *bwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal anrm, bnrm; + integer idum[1], ierr, itau, iwrk; + doublereal pvsl, pvsr; + integer i__; + extern logical lsame_(char *, char *); + integer ileft, icols; + logical cursl, ilvsl, ilvsr; + extern /* Subroutine */ int dgghd3_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer irows; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dggbak_( + char *, char *, integer *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer + *, doublereal *, integer *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *); + logical lst2sl; + extern doublereal dlamch_(char *); + integer ip; + extern doublereal dlange_(char *, integer *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + doublereal safmax; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), dtgsen_(integer *, logical *, + logical *, logical *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, integer *, integer *); + integer ijobvl, iright, ijobvr; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal anrmto, bnrmto; + logical lastsl; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + doublereal smlnum; + logical wantst, lquery; + integer lwkopt; + doublereal dif[2]; + integer ihi, ilo; + doublereal eps; + + +/* -- LAPACK driver routine (version 3.6.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* January 2015 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1 * 1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1 * 1; + vsr -= vsr_offset; + --work; + --bwork; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = FALSE_; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = TRUE_; + } else { + ijobvl = -1; + ilvsl = FALSE_; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = FALSE_; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = TRUE_; + } else { + ijobvr = -1; + ilvsr = FALSE_; + } + + wantst = lsame_(sort, "S"); + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -3; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -15; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -17; + } else if (*lwork < *n * 6 + 16 && ! lquery) { + *info = -19; + } + +/* Compute workspace */ + + if (*info == 0) { + dgeqrf_(n, n, &b[b_offset], ldb, &work[1], &work[1], &c_n1, &ierr); +/* Computing MAX */ + i__1 = *n * 6 + 16, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + dormqr_("L", "T", n, n, n, &b[b_offset], ldb, &work[1], &a[a_offset], + lda, &work[1], &c_n1, &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + if (ilvsl) { + dorgqr_(n, n, n, &vsl[vsl_offset], ldvsl, &work[1], &work[1], & + c_n1, &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + } + dgghd3_(jobvsl, jobvsr, n, &c__1, n, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &work[ + 1], &c_n1, &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + dhgeqz_("S", jobvsl, jobvsr, n, &c__1, n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ + vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &work[1], &c_n1, + &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (*n << 1) + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + if (wantst) { + dtgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, & + b[b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ + vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, + &pvsr, dif, &work[1], &c_n1, idum, &c__1, &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (*n << 1) + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + } + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGES3 ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + safmin = dlamch_("S"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + smlnum = sqrt(safmin) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VSL */ + + if (ilvsl) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl); + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ + ilo + 1 + ilo * vsl_dim1], ldvsl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VSR */ + + if (ilvsr) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ + + i__1 = *lwork + 1 - iwrk; + dgghd3_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk] + , &i__1, &ierr); + +/* Perform QZ algorithm, computing Schur vectors if desired */ + + iwrk = itau; + i__1 = *lwork + 1 - iwrk; + dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] + , ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L50; + } + +/* Sort eigenvalues ALPHA/BETA if desired */ + + *sdim = 0; + if (wantst) { + +/* Undo scaling on eigenvalues before SELCTGing */ + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], + n, &ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], + n, &ierr); + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, + &ierr); + } + +/* Select eigenvalues */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); +/* L10: */ + } + + i__1 = *lwork - iwrk + 1; + dtgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ + vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, & + pvsr, dif, &work[iwrk], &i__1, idum, &c__1, &ierr); + if (ierr == 1) { + *info = *n + 3; + } + + } + +/* Apply back-permutation to VSL and VSR */ + + if (ilvsl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &ierr); + } + + if (ilvsr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &ierr); + } + +/* Check if unscaling would cause over/underflow, if so, rescale */ +/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */ +/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */ + + if (ilascl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[ + i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__], + abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } else if (alphai[i__] / safmax > anrmto / anrm || safmin / + alphai[i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[ + i__], abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L20: */ + } + } + + if (ilbscl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__] + > bnrm / bnrmto) { + work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs( + d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L30: */ + } + } + +/* Undo scaling */ + + if (ilascl) { + dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + ierr); + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + if (wantst) { + +/* Check if reordering is correct */ + + lastsl = TRUE_; + lst2sl = TRUE_; + *sdim = 0; + ip = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); + if (alphai[i__] == 0.) { + if (cursl) { + ++(*sdim); + } + ip = 0; + if (cursl && ! lastsl) { + *info = *n + 2; + } + } else { + if (ip == 1) { + +/* Last eigenvalue of conjugate pair */ + + cursl = cursl || lastsl; + lastsl = cursl; + if (cursl) { + *sdim += 2; + } + ip = -1; + if (cursl && ! lst2sl) { + *info = *n + 2; + } + } else { + +/* First eigenvalue of conjugate pair */ + + ip = 1; + } + } + lst2sl = lastsl; + lastsl = cursl; +/* L40: */ + } + + } + +L50: + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DGGES3 */ + +} /* dgges3_ */ + diff --git a/lapack-netlib/SRC/dggesx.c b/lapack-netlib/SRC/dggesx.c new file mode 100644 index 000000000..7a8675c0b --- /dev/null +++ b/lapack-netlib/SRC/dggesx.c @@ -0,0 +1,1316 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors +for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGESX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, */ +/* B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, */ +/* VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, */ +/* LIWORK, BWORK, INFO ) */ + +/* CHARACTER JOBVSL, JOBVSR, SENSE, SORT */ +/* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, */ +/* $ SDIM */ +/* LOGICAL BWORK( * ) */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), RCONDE( 2 ), */ +/* $ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ), */ +/* $ WORK( * ) */ +/* LOGICAL SELCTG */ +/* EXTERNAL SELCTG */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGESX computes for a pair of N-by-N real nonsymmetric matrices */ +/* > (A,B), the generalized eigenvalues, the real Schur form (S,T), and, */ +/* > optionally, the left and/or right matrices of Schur vectors (VSL and */ +/* > VSR). This gives the generalized Schur factorization */ +/* > */ +/* > (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) */ +/* > */ +/* > Optionally, it also orders the eigenvalues so that a selected cluster */ +/* > of eigenvalues appears in the leading diagonal blocks of the upper */ +/* > quasi-triangular matrix S and the upper triangular matrix T; computes */ +/* > a reciprocal condition number for the average of the selected */ +/* > eigenvalues (RCONDE); and computes a reciprocal condition number for */ +/* > the right and left deflating subspaces corresponding to the selected */ +/* > eigenvalues (RCONDV). The leading columns of VSL and VSR then form */ +/* > an orthonormal basis for the corresponding left and right eigenspaces */ +/* > (deflating subspaces). */ +/* > */ +/* > A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */ +/* > or a ratio alpha/beta = w, such that A - w*B is singular. It is */ +/* > usually represented as the pair (alpha,beta), as there is a */ +/* > reasonable interpretation for beta=0 or for both being zero. */ +/* > */ +/* > A pair of matrices (S,T) is in generalized real Schur form if T is */ +/* > upper triangular with non-negative diagonal and S is block upper */ +/* > triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */ +/* > to real generalized eigenvalues, while 2-by-2 blocks of S will be */ +/* > "standardized" by making the corresponding elements of T have the */ +/* > form: */ +/* > [ a 0 ] */ +/* > [ 0 b ] */ +/* > */ +/* > and the pair of corresponding 2-by-2 blocks in S and T will have a */ +/* > complex conjugate pair of generalized eigenvalues. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVSL */ +/* > \verbatim */ +/* > JOBVSL is CHARACTER*1 */ +/* > = 'N': do not compute the left Schur vectors; */ +/* > = 'V': compute the left Schur vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVSR */ +/* > \verbatim */ +/* > JOBVSR is CHARACTER*1 */ +/* > = 'N': do not compute the right Schur vectors; */ +/* > = 'V': compute the right Schur vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SORT */ +/* > \verbatim */ +/* > SORT is CHARACTER*1 */ +/* > Specifies whether or not to order the eigenvalues on the */ +/* > diagonal of the generalized Schur form. */ +/* > = 'N': Eigenvalues are not ordered; */ +/* > = 'S': Eigenvalues are ordered (see SELCTG). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELCTG */ +/* > \verbatim */ +/* > SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments */ +/* > SELCTG must be declared EXTERNAL in the calling subroutine. */ +/* > If SORT = 'N', SELCTG is not referenced. */ +/* > If SORT = 'S', SELCTG is used to select eigenvalues to sort */ +/* > to the top left of the Schur form. */ +/* > An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */ +/* > SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */ +/* > one of a complex conjugate pair of eigenvalues is selected, */ +/* > then both complex eigenvalues are selected. */ +/* > Note that a selected complex eigenvalue may no longer satisfy */ +/* > SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, */ +/* > since ordering may change the value of complex eigenvalues */ +/* > (especially if the eigenvalue is ill-conditioned), in this */ +/* > case INFO is set to N+3. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SENSE */ +/* > \verbatim */ +/* > SENSE is CHARACTER*1 */ +/* > Determines which reciprocal condition numbers are computed. */ +/* > = 'N': None are computed; */ +/* > = 'E': Computed for average of selected eigenvalues only; */ +/* > = 'V': Computed for selected deflating subspaces only; */ +/* > = 'B': Computed for both. */ +/* > If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VSL, and VSR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the first of the pair of matrices. */ +/* > On exit, A has been overwritten by its generalized Schur */ +/* > form S. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the second of the pair of matrices. */ +/* > On exit, B has been overwritten by its generalized Schur */ +/* > form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SDIM */ +/* > \verbatim */ +/* > SDIM is INTEGER */ +/* > If SORT = 'N', SDIM = 0. */ +/* > If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ +/* > for which SELCTG is true. (Complex conjugate pairs for which */ +/* > SELCTG is true for either eigenvalue count as 2.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */ +/* > and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* > form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* > the real Schur form of (A,B) were further reduced to */ +/* > triangular form using 2-by-2 complex unitary transformations. */ +/* > If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* > positive, then the j-th and (j+1)-st eigenvalues are a */ +/* > complex conjugate pair, with ALPHAI(j+1) negative. */ +/* > */ +/* > Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* > may easily over- or underflow, and BETA(j) may even be zero. */ +/* > Thus, the user should avoid naively computing the ratio. */ +/* > However, ALPHAR and ALPHAI will be always less than and */ +/* > usually comparable with norm(A) in magnitude, and BETA always */ +/* > less than and usually comparable with norm(B). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSL */ +/* > \verbatim */ +/* > VSL is DOUBLE PRECISION array, dimension (LDVSL,N) */ +/* > If JOBVSL = 'V', VSL will contain the left Schur vectors. */ +/* > Not referenced if JOBVSL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSL */ +/* > \verbatim */ +/* > LDVSL is INTEGER */ +/* > The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* > if JOBVSL = 'V', LDVSL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSR */ +/* > \verbatim */ +/* > VSR is DOUBLE PRECISION array, dimension (LDVSR,N) */ +/* > If JOBVSR = 'V', VSR will contain the right Schur vectors. */ +/* > Not referenced if JOBVSR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSR */ +/* > \verbatim */ +/* > LDVSR is INTEGER */ +/* > The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* > if JOBVSR = 'V', LDVSR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDE */ +/* > \verbatim */ +/* > RCONDE is DOUBLE PRECISION array, dimension ( 2 ) */ +/* > If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the */ +/* > reciprocal condition numbers for the average of the selected */ +/* > eigenvalues. */ +/* > Not referenced if SENSE = 'N' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDV */ +/* > \verbatim */ +/* > RCONDV is DOUBLE PRECISION array, dimension ( 2 ) */ +/* > If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the */ +/* > reciprocal condition numbers for the selected deflating */ +/* > subspaces. */ +/* > Not referenced if SENSE = 'N' or 'E'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', */ +/* > LWORK >= f2cmax( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else */ +/* > LWORK >= f2cmax( 8*N, 6*N+16 ). */ +/* > Note that 2*SDIM*(N-SDIM) <= N*N/2. */ +/* > Note also that an error is only returned if */ +/* > LWORK < f2cmax( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B' */ +/* > this may not be large enough. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the bound on the optimal size of the WORK */ +/* > array and the minimum size of the IWORK array, returns these */ +/* > values as the first entries of the WORK and IWORK arrays, and */ +/* > no error message related to LWORK or LIWORK is issued by */ +/* > XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise */ +/* > LIWORK >= N+6. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the bound on the optimal size of the */ +/* > WORK array and the minimum size of the IWORK array, returns */ +/* > these values as the first entries of the WORK and IWORK */ +/* > arrays, and no error message related to LWORK or LIWORK is */ +/* > issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BWORK */ +/* > \verbatim */ +/* > BWORK is LOGICAL array, dimension (N) */ +/* > Not referenced if SORT = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. (A,B) are not in Schur */ +/* > form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* > be correct for j=INFO+1,...,N. */ +/* > > N: =N+1: other than QZ iteration failed in DHGEQZ */ +/* > =N+2: after reordering, roundoff changed values of */ +/* > some complex eigenvalues so that leading */ +/* > eigenvalues in the Generalized Schur form no */ +/* > longer satisfy SELCTG=.TRUE. This could also */ +/* > be caused due to scaling. */ +/* > =N+3: reordering failed in DTGSEN. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleGEeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > An approximate (asymptotic) bound on the average absolute error of */ +/* > the selected eigenvalues is */ +/* > */ +/* > EPS * norm((A, B)) / RCONDE( 1 ). */ +/* > */ +/* > An approximate (asymptotic) bound on the maximum angular error in */ +/* > the computed deflating subspaces is */ +/* > */ +/* > EPS * norm((A, B)) / RCONDV( 2 ). */ +/* > */ +/* > See LAPACK User's Guide, section 4.11 for more information. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp + selctg, char *sense, integer *n, doublereal *a, integer *lda, + doublereal *b, integer *ldb, integer *sdim, doublereal *alphar, + doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl, + doublereal *vsr, integer *ldvsr, doublereal *rconde, doublereal * + rcondv, doublereal *work, integer *lwork, integer *iwork, integer * + liwork, logical *bwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer ijob; + doublereal anrm, bnrm; + integer ierr, itau, iwrk, lwrk, i__; + extern logical lsame_(char *, char *); + integer ileft, icols; + logical cursl, ilvsl, ilvsr; + integer irows; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dggbak_( + char *, char *, integer *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer + *, doublereal *, integer *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *); + logical lst2sl; + extern doublereal dlamch_(char *); + integer ip; + extern doublereal dlange_(char *, integer *, integer *, doublereal *, + integer *, doublereal *); + doublereal pl; + extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *); + doublereal pr; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + doublereal safmax; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *); + integer ijobvl, iright; + extern /* Subroutine */ int dtgsen_(integer *, logical *, logical *, + logical *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ijobvr; + logical wantsb; + integer liwmin; + logical wantse, lastsl; + doublereal anrmto, bnrmto; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + integer minwrk, maxwrk; + logical wantsn; + doublereal smlnum; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + logical wantst, lquery, wantsv; + doublereal dif[2]; + integer ihi, ilo; + doublereal eps; + + +/* -- LAPACK driver routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1 * 1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1 * 1; + vsr -= vsr_offset; + --rconde; + --rcondv; + --work; + --iwork; + --bwork; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = FALSE_; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = TRUE_; + } else { + ijobvl = -1; + ilvsl = FALSE_; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = FALSE_; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = TRUE_; + } else { + ijobvr = -1; + ilvsr = FALSE_; + } + + wantst = lsame_(sort, "S"); + wantsn = lsame_(sense, "N"); + wantse = lsame_(sense, "E"); + wantsv = lsame_(sense, "V"); + wantsb = lsame_(sense, "B"); + lquery = *lwork == -1 || *liwork == -1; + if (wantsn) { + ijob = 0; + } else if (wantse) { + ijob = 1; + } else if (wantsv) { + ijob = 2; + } else if (wantsb) { + ijob = 4; + } + +/* Test the input arguments */ + + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -3; + } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! + wantsn) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*n)) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -16; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -18; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + if (*n > 0) { +/* Computing MAX */ + i__1 = *n << 3, i__2 = *n * 6 + 16; + minwrk = f2cmax(i__1,i__2); + maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & + c__1, n, &c__0, (ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR", + " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + if (ilvsl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR" + "GQR", " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + } + lwrk = maxwrk; + if (ijob >= 1) { +/* Computing MAX */ + i__1 = lwrk, i__2 = *n * *n / 2; + lwrk = f2cmax(i__1,i__2); + } + } else { + minwrk = 1; + maxwrk = 1; + lwrk = 1; + } + work[1] = (doublereal) lwrk; + if (wantsn || *n == 0) { + liwmin = 1; + } else { + liwmin = *n + 6; + } + iwork[1] = liwmin; + + if (*lwork < minwrk && ! lquery) { + *info = -22; + } else if (*liwork < liwmin && ! lquery) { + *info = -24; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGESX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + safmin = dlamch_("S"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + smlnum = sqrt(safmin) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ +/* (Workspace: need 6*N + 2*N for permutation parameters) */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB) */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VSL */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvsl) { + dlaset_("Full", n, n, &c_b42, &c_b43, &vsl[vsl_offset], ldvsl); + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ + ilo + 1 + ilo * vsl_dim1], ldvsl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VSR */ + + if (ilvsr) { + dlaset_("Full", n, n, &c_b42, &c_b43, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr); + + *sdim = 0; + +/* Perform QZ algorithm, computing Schur vectors if desired */ +/* (Workspace: need N) */ + + iwrk = itau; + i__1 = *lwork + 1 - iwrk; + dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] + , ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L60; + } + +/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of */ +/* condition number(s) */ +/* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) */ +/* otherwise, need 8*(N+1) ) */ + + if (wantst) { + +/* Undo scaling on eigenvalues before SELCTGing */ + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], + n, &ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], + n, &ierr); + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, + &ierr); + } + +/* Select eigenvalues */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); +/* L10: */ + } + +/* Reorder eigenvalues, transform Generalized Schur vectors, and */ +/* compute reciprocal condition numbers */ + + i__1 = *lwork - iwrk + 1; + dtgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ + vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pl, &pr, + dif, &work[iwrk], &i__1, &iwork[1], liwork, &ierr); + + if (ijob >= 1) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim); + maxwrk = f2cmax(i__1,i__2); + } + if (ierr == -22) { + +/* not enough real workspace */ + + *info = -22; + } else { + if (ijob == 1 || ijob == 4) { + rconde[1] = pl; + rconde[2] = pr; + } + if (ijob == 2 || ijob == 4) { + rcondv[1] = dif[0]; + rcondv[2] = dif[1]; + } + if (ierr == 1) { + *info = *n + 3; + } + } + + } + +/* Apply permutation to VSL and VSR */ +/* (Workspace: none needed) */ + + if (ilvsl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &ierr); + } + + if (ilvsr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &ierr); + } + +/* Check if unscaling would cause over/underflow, if so, rescale */ +/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */ +/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */ + + if (ilascl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[ + i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__], + abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } else if (alphai[i__] / safmax > anrmto / anrm || safmin / + alphai[i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[ + i__], abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L20: */ + } + } + + if (ilbscl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__] + > bnrm / bnrmto) { + work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs( + d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L30: */ + } + } + +/* Undo scaling */ + + if (ilascl) { + dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + ierr); + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + if (wantst) { + +/* Check if reordering is correct */ + + lastsl = TRUE_; + lst2sl = TRUE_; + *sdim = 0; + ip = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); + if (alphai[i__] == 0.) { + if (cursl) { + ++(*sdim); + } + ip = 0; + if (cursl && ! lastsl) { + *info = *n + 2; + } + } else { + if (ip == 1) { + +/* Last eigenvalue of conjugate pair */ + + cursl = cursl || lastsl; + lastsl = cursl; + if (cursl) { + *sdim += 2; + } + ip = -1; + if (cursl && ! lst2sl) { + *info = *n + 2; + } + } else { + +/* First eigenvalue of conjugate pair */ + + ip = 1; + } + } + lst2sl = lastsl; + lastsl = cursl; +/* L50: */ + } + + } + +L60: + + work[1] = (doublereal) maxwrk; + iwork[1] = liwmin; + + return 0; + +/* End of DGGESX */ + +} /* dggesx_ */ + diff --git a/lapack-netlib/SRC/dggev.c b/lapack-netlib/SRC/dggev.c new file mode 100644 index 000000000..3352f559b --- /dev/null +++ b/lapack-netlib/SRC/dggev.c @@ -0,0 +1,1102 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matr +ices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGEV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, */ +/* BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) */ + +/* CHARACTER JOBVL, JOBVR */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) */ +/* > the generalized eigenvalues, and optionally, the left and/or right */ +/* > generalized eigenvectors. */ +/* > */ +/* > A generalized eigenvalue for a pair of matrices (A,B) is a scalar */ +/* > lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */ +/* > singular. It is usually represented as the pair (alpha,beta), as */ +/* > there is a reasonable interpretation for beta=0, and even for both */ +/* > being zero. */ +/* > */ +/* > The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */ +/* > of (A,B) satisfies */ +/* > */ +/* > A * v(j) = lambda(j) * B * v(j). */ +/* > */ +/* > The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */ +/* > of (A,B) satisfies */ +/* > */ +/* > u(j)**H * A = lambda(j) * u(j)**H * B . */ +/* > */ +/* > where u(j)**H is the conjugate-transpose of u(j). */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': do not compute the left generalized eigenvectors; */ +/* > = 'V': compute the left generalized eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': do not compute the right generalized eigenvectors; */ +/* > = 'V': compute the right generalized eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VL, and VR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the matrix A in the pair (A,B). */ +/* > On exit, A has been overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the matrix B in the pair (A,B). */ +/* > On exit, B has been overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. If ALPHAI(j) is zero, then */ +/* > the j-th eigenvalue is real; if positive, then the j-th and */ +/* > (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* > ALPHAI(j+1) negative. */ +/* > */ +/* > Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* > may easily over- or underflow, and BETA(j) may even be zero. */ +/* > Thus, the user should avoid naively computing the ratio */ +/* > alpha/beta. However, ALPHAR and ALPHAI will be always less */ +/* > than and usually comparable with norm(A) in magnitude, and */ +/* > BETA always less than and usually comparable with norm(B). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* > after another in the columns of VL, in the same order as */ +/* > their eigenvalues. If the j-th eigenvalue is real, then */ +/* > u(j) = VL(:,j), the j-th column of VL. If the j-th and */ +/* > (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* > u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */ +/* > Each eigenvector is scaled so the largest component has */ +/* > abs(real part)+abs(imag. part)=1. */ +/* > Not referenced if JOBVL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the matrix VL. LDVL >= 1, and */ +/* > if JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* > after another in the columns of VR, in the same order as */ +/* > their eigenvalues. If the j-th eigenvalue is real, then */ +/* > v(j) = VR(:,j), the j-th column of VR. If the j-th and */ +/* > (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* > v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */ +/* > Each eigenvector is scaled so the largest component has */ +/* > abs(real part)+abs(imag. part)=1. */ +/* > Not referenced if JOBVR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the matrix VR. LDVR >= 1, and */ +/* > if JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,8*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. No eigenvectors have been */ +/* > calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* > should be correct for j=INFO+1,...,N. */ +/* > > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* > =N+2: error return from DTGEVC. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleGEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dggev_(char *jobvl, char *jobvr, integer *n, doublereal * + a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, + doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, + doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal anrm, bnrm; + integer ierr, itau; + doublereal temp; + logical ilvl, ilvr; + integer iwrk; + extern logical lsame_(char *, char *); + integer ileft, icols, irows; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + integer jc; + extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *), dggbal_(char *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *); + integer in; + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + integer jr; + extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *), dlaset_(char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *), dtgevc_(char *, char *, logical *, integer *, doublereal + *, integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, doublereal *, + integer *); + logical ldumma[1]; + char chtemp[1]; + doublereal bignum; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ijobvl, iright, ijobvr; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal anrmto, bnrmto; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer minwrk, maxwrk; + doublereal smlnum; + logical lquery; + integer ihi, ilo; + doublereal eps; + logical ilv; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = FALSE_; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = TRUE_; + } else { + ijobvl = -1; + ilvl = FALSE_; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = FALSE_; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = TRUE_; + } else { + ijobvr = -1; + ilvr = FALSE_; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -12; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -14; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. The workspace is */ +/* computed assuming ILO = 1 and IHI = N, the worst case.) */ + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 3; + minwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * (ilaenv_(&c__1, "DGEQRF", " ", n, &c__1, n, & + c__0, (ftnlen)6, (ftnlen)1) + 7); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORMQR", " ", n, &c__1, n, + &c__0, (ftnlen)6, (ftnlen)1) + 7); + maxwrk = f2cmax(i__1,i__2); + if (ilvl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORGQR", " ", n, & + c__1, n, &c_n1, (ftnlen)6, (ftnlen)1) + 7); + maxwrk = f2cmax(i__1,i__2); + } + work[1] = (doublereal) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -16; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGEV ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrices A, B to isolate eigenvalues if possible */ +/* (Workspace: need 6*N) */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB) */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VL */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvl) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vl[vl_offset], ldvl) + ; + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ + ilo + 1 + ilo * vl_dim1], ldvl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VR */ + + if (ilvr) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); + } else { + dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &ierr); + } + +/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */ +/* Schur forms and Schur vectors) */ +/* (Workspace: need N) */ + + iwrk = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwrk; + dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L110; + } + +/* Compute Eigenvectors */ +/* (Workspace: need 6*N) */ + + if (ilv) { + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwrk], &ierr); + if (ierr != 0) { + *info = *n + 2; + goto L110; + } + +/* Undo balancing on VL and VR and normalization */ +/* (Workspace: none needed) */ + + if (ilvl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vl[vl_offset], ldvl, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L50; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L10: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)) + (d__2 = vl[jr + (jc + 1) * + vl_dim1], abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L20: */ + } + } + if (temp < smlnum) { + goto L50; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L40: */ + } + } +L50: + ; + } + } + if (ilvr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vr[vr_offset], ldvr, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L100; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L60: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)) + (d__2 = vr[jr + (jc + 1) * + vr_dim1], abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L70: */ + } + } + if (temp < smlnum) { + goto L100; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L90: */ + } + } +L100: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling if necessary */ + +L110: + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + work[1] = (doublereal) maxwrk; + return 0; + +/* End of DGGEV */ + +} /* dggev_ */ + diff --git a/lapack-netlib/SRC/dggev3.c b/lapack-netlib/SRC/dggev3.c new file mode 100644 index 000000000..008965fdd --- /dev/null +++ b/lapack-netlib/SRC/dggev3.c @@ -0,0 +1,1122 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices (blocked algorithm) */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGEV3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, */ +/* $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, */ +/* $ INFO ) */ + +/* CHARACTER JOBVL, JOBVR */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B) */ +/* > the generalized eigenvalues, and optionally, the left and/or right */ +/* > generalized eigenvectors. */ +/* > */ +/* > A generalized eigenvalue for a pair of matrices (A,B) is a scalar */ +/* > lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */ +/* > singular. It is usually represented as the pair (alpha,beta), as */ +/* > there is a reasonable interpretation for beta=0, and even for both */ +/* > being zero. */ +/* > */ +/* > The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */ +/* > of (A,B) satisfies */ +/* > */ +/* > A * v(j) = lambda(j) * B * v(j). */ +/* > */ +/* > The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */ +/* > of (A,B) satisfies */ +/* > */ +/* > u(j)**H * A = lambda(j) * u(j)**H * B . */ +/* > */ +/* > where u(j)**H is the conjugate-transpose of u(j). */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': do not compute the left generalized eigenvectors; */ +/* > = 'V': compute the left generalized eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': do not compute the right generalized eigenvectors; */ +/* > = 'V': compute the right generalized eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VL, and VR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the matrix A in the pair (A,B). */ +/* > On exit, A has been overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the matrix B in the pair (A,B). */ +/* > On exit, B has been overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. If ALPHAI(j) is zero, then */ +/* > the j-th eigenvalue is real; if positive, then the j-th and */ +/* > (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* > ALPHAI(j+1) negative. */ +/* > */ +/* > Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* > may easily over- or underflow, and BETA(j) may even be zero. */ +/* > Thus, the user should avoid naively computing the ratio */ +/* > alpha/beta. However, ALPHAR and ALPHAI will be always less */ +/* > than and usually comparable with norm(A) in magnitude, and */ +/* > BETA always less than and usually comparable with norm(B). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* > after another in the columns of VL, in the same order as */ +/* > their eigenvalues. If the j-th eigenvalue is real, then */ +/* > u(j) = VL(:,j), the j-th column of VL. If the j-th and */ +/* > (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* > u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */ +/* > Each eigenvector is scaled so the largest component has */ +/* > abs(real part)+abs(imag. part)=1. */ +/* > Not referenced if JOBVL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the matrix VL. LDVL >= 1, and */ +/* > if JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* > after another in the columns of VR, in the same order as */ +/* > their eigenvalues. If the j-th eigenvalue is real, then */ +/* > v(j) = VR(:,j), the j-th column of VR. If the j-th and */ +/* > (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* > v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */ +/* > Each eigenvector is scaled so the largest component has */ +/* > abs(real part)+abs(imag. part)=1. */ +/* > Not referenced if JOBVR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the matrix VR. LDVR >= 1, and */ +/* > if JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. No eigenvectors have been */ +/* > calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* > should be correct for j=INFO+1,...,N. */ +/* > > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* > =N+2: error return from DTGEVC. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date January 2015 */ + +/* > \ingroup doubleGEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dggev3_(char *jobvl, char *jobvr, integer *n, doublereal + *a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, + doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, + doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal anrm, bnrm; + integer ierr, itau; + doublereal temp; + logical ilvl, ilvr; + integer iwrk; + extern logical lsame_(char *, char *); + integer ileft, icols; + extern /* Subroutine */ int dgghd3_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer irows; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + integer jc; + extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *), dggbal_(char *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *); + integer in; + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + integer jr; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *), dlaset_(char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *), dtgevc_(char *, char *, logical *, integer *, doublereal + *, integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, doublereal *, + integer *); + logical ldumma[1]; + char chtemp[1]; + doublereal bignum; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + integer ijobvl, iright, ijobvr; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal anrmto, bnrmto; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + doublereal smlnum; + integer lwkopt; + logical lquery; + integer ihi, ilo; + doublereal eps; + logical ilv; + + +/* -- LAPACK driver routine (version 3.6.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* January 2015 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = FALSE_; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = TRUE_; + } else { + ijobvl = -1; + ilvl = FALSE_; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = FALSE_; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = TRUE_; + } else { + ijobvr = -1; + ilvr = FALSE_; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -12; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -14; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 3; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -16; + } + } + +/* Compute workspace */ + + if (*info == 0) { + dgeqrf_(n, n, &b[b_offset], ldb, &work[1], &work[1], &c_n1, &ierr); +/* Computing MAX */ + i__1 = 1, i__2 = *n << 3, i__1 = f2cmax(i__1,i__2), i__2 = *n * 3 + ( + integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + dormqr_("L", "T", n, n, n, &b[b_offset], ldb, &work[1], &a[a_offset], + lda, &work[1], &c_n1, &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + if (ilvl) { + dorgqr_(n, n, n, &vl[vl_offset], ldvl, &work[1], &work[1], &c_n1, + &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + } + if (ilv) { + dgghd3_(jobvl, jobvr, n, &c__1, n, &a[a_offset], lda, &b[b_offset] + , ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &work[ + 1], &c_n1, &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + dhgeqz_("S", jobvl, jobvr, n, &c__1, n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &c_n1, & + ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (*n << 1) + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + } else { + dgghd3_("N", "N", n, &c__1, n, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], + &c_n1, &ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * 3 + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + dhgeqz_("E", jobvl, jobvr, n, &c__1, n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &c_n1, & + ierr); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (*n << 1) + (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + } + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGEV3 ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrices A, B to isolate eigenvalues if possible */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VL */ + + if (ilvl) { + dlaset_("Full", n, n, &c_b38, &c_b39, &vl[vl_offset], ldvl) + ; + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ + ilo + 1 + ilo * vl_dim1], ldvl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VR */ + + if (ilvr) { + dlaset_("Full", n, n, &c_b38, &c_b39, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + i__1 = *lwork + 1 - iwrk; + dgghd3_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &work[iwrk], + &i__1, &ierr); + } else { + i__1 = *lwork + 1 - iwrk; + dgghd3_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &work[iwrk], &i__1, &ierr); + } + +/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */ +/* Schur forms and Schur vectors) */ + + iwrk = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwrk; + dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L110; + } + +/* Compute Eigenvectors */ + + if (ilv) { + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwrk], &ierr); + if (ierr != 0) { + *info = *n + 2; + goto L110; + } + +/* Undo balancing on VL and VR and normalization */ + + if (ilvl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vl[vl_offset], ldvl, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L50; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L10: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)) + (d__2 = vl[jr + (jc + 1) * + vl_dim1], abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L20: */ + } + } + if (temp < smlnum) { + goto L50; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L40: */ + } + } +L50: + ; + } + } + if (ilvr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vr[vr_offset], ldvr, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L100; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L60: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)) + (d__2 = vr[jr + (jc + 1) * + vr_dim1], abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L70: */ + } + } + if (temp < smlnum) { + goto L100; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L90: */ + } + } +L100: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling if necessary */ + +L110: + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DGGEV3 */ + +} /* dggev3_ */ + diff --git a/lapack-netlib/SRC/dggevx.c b/lapack-netlib/SRC/dggevx.c new file mode 100644 index 000000000..b899f8ed7 --- /dev/null +++ b/lapack-netlib/SRC/dggevx.c @@ -0,0 +1,1396 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGEVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, */ +/* ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, */ +/* IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, */ +/* RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) */ + +/* CHARACTER BALANC, JOBVL, JOBVR, SENSE */ +/* INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N */ +/* DOUBLE PRECISION ABNRM, BBNRM */ +/* LOGICAL BWORK( * ) */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), LSCALE( * ), */ +/* $ RCONDE( * ), RCONDV( * ), RSCALE( * ), */ +/* $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) */ +/* > the generalized eigenvalues, and optionally, the left and/or right */ +/* > generalized eigenvectors. */ +/* > */ +/* > Optionally also, it computes a balancing transformation to improve */ +/* > the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ +/* > LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */ +/* > the eigenvalues (RCONDE), and reciprocal condition numbers for the */ +/* > right eigenvectors (RCONDV). */ +/* > */ +/* > A generalized eigenvalue for a pair of matrices (A,B) is a scalar */ +/* > lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */ +/* > singular. It is usually represented as the pair (alpha,beta), as */ +/* > there is a reasonable interpretation for beta=0, and even for both */ +/* > being zero. */ +/* > */ +/* > The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */ +/* > of (A,B) satisfies */ +/* > */ +/* > A * v(j) = lambda(j) * B * v(j) . */ +/* > */ +/* > The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */ +/* > of (A,B) satisfies */ +/* > */ +/* > u(j)**H * A = lambda(j) * u(j)**H * B. */ +/* > */ +/* > where u(j)**H is the conjugate-transpose of u(j). */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] BALANC */ +/* > \verbatim */ +/* > BALANC is CHARACTER*1 */ +/* > Specifies the balance option to be performed. */ +/* > = 'N': do not diagonally scale or permute; */ +/* > = 'P': permute only; */ +/* > = 'S': scale only; */ +/* > = 'B': both permute and scale. */ +/* > Computed reciprocal condition numbers will be for the */ +/* > matrices after permuting and/or balancing. Permuting does */ +/* > not change condition numbers (in exact arithmetic), but */ +/* > balancing does. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': do not compute the left generalized eigenvectors; */ +/* > = 'V': compute the left generalized eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': do not compute the right generalized eigenvectors; */ +/* > = 'V': compute the right generalized eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SENSE */ +/* > \verbatim */ +/* > SENSE is CHARACTER*1 */ +/* > Determines which reciprocal condition numbers are computed. */ +/* > = 'N': none are computed; */ +/* > = 'E': computed for eigenvalues only; */ +/* > = 'V': computed for eigenvectors only; */ +/* > = 'B': computed for eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VL, and VR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the matrix A in the pair (A,B). */ +/* > On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */ +/* > or both, then A contains the first part of the real Schur */ +/* > form of the "balanced" versions of the input A and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the matrix B in the pair (A,B). */ +/* > On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */ +/* > or both, then B contains the second part of the real Schur */ +/* > form of the "balanced" versions of the input A and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. If ALPHAI(j) is zero, then */ +/* > the j-th eigenvalue is real; if positive, then the j-th and */ +/* > (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* > ALPHAI(j+1) negative. */ +/* > */ +/* > Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* > may easily over- or underflow, and BETA(j) may even be zero. */ +/* > Thus, the user should avoid naively computing the ratio */ +/* > ALPHA/BETA. However, ALPHAR and ALPHAI will be always less */ +/* > than and usually comparable with norm(A) in magnitude, and */ +/* > BETA always less than and usually comparable with norm(B). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* > after another in the columns of VL, in the same order as */ +/* > their eigenvalues. If the j-th eigenvalue is real, then */ +/* > u(j) = VL(:,j), the j-th column of VL. If the j-th and */ +/* > (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* > u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */ +/* > Each eigenvector will be scaled so the largest component have */ +/* > abs(real part) + abs(imag. part) = 1. */ +/* > Not referenced if JOBVL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the matrix VL. LDVL >= 1, and */ +/* > if JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* > after another in the columns of VR, in the same order as */ +/* > their eigenvalues. If the j-th eigenvalue is real, then */ +/* > v(j) = VR(:,j), the j-th column of VR. If the j-th and */ +/* > (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* > v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */ +/* > Each eigenvector will be scaled so the largest component have */ +/* > abs(real part) + abs(imag. part) = 1. */ +/* > Not referenced if JOBVR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the matrix VR. LDVR >= 1, and */ +/* > if JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > ILO and IHI are integer values such that on exit */ +/* > A(i,j) = 0 and B(i,j) = 0 if i > j and */ +/* > j = 1,...,ILO-1 or i = IHI+1,...,N. */ +/* > If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] LSCALE */ +/* > \verbatim */ +/* > LSCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and scaling factors applied */ +/* > to the left side of A and B. If PL(j) is the index of the */ +/* > row interchanged with row j, and DL(j) is the scaling */ +/* > factor applied to row j, then */ +/* > LSCALE(j) = PL(j) for j = 1,...,ILO-1 */ +/* > = DL(j) for j = ILO,...,IHI */ +/* > = PL(j) for j = IHI+1,...,N. */ +/* > The order in which the interchanges are made is N to IHI+1, */ +/* > then 1 to ILO-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RSCALE */ +/* > \verbatim */ +/* > RSCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and scaling factors applied */ +/* > to the right side of A and B. If PR(j) is the index of the */ +/* > column interchanged with column j, and DR(j) is the scaling */ +/* > factor applied to column j, then */ +/* > RSCALE(j) = PR(j) for j = 1,...,ILO-1 */ +/* > = DR(j) for j = ILO,...,IHI */ +/* > = PR(j) for j = IHI+1,...,N */ +/* > The order in which the interchanges are made is N to IHI+1, */ +/* > then 1 to ILO-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ABNRM */ +/* > \verbatim */ +/* > ABNRM is DOUBLE PRECISION */ +/* > The one-norm of the balanced matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BBNRM */ +/* > \verbatim */ +/* > BBNRM is DOUBLE PRECISION */ +/* > The one-norm of the balanced matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDE */ +/* > \verbatim */ +/* > RCONDE is DOUBLE PRECISION array, dimension (N) */ +/* > If SENSE = 'E' or 'B', the reciprocal condition numbers of */ +/* > the eigenvalues, stored in consecutive elements of the array. */ +/* > For a complex conjugate pair of eigenvalues two consecutive */ +/* > elements of RCONDE are set to the same value. Thus RCONDE(j), */ +/* > RCONDV(j), and the j-th columns of VL and VR all correspond */ +/* > to the j-th eigenpair. */ +/* > If SENSE = 'N or 'V', RCONDE is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDV */ +/* > \verbatim */ +/* > RCONDV is DOUBLE PRECISION array, dimension (N) */ +/* > If SENSE = 'V' or 'B', the estimated reciprocal condition */ +/* > numbers of the eigenvectors, stored in consecutive elements */ +/* > of the array. For a complex eigenvector two consecutive */ +/* > elements of RCONDV are set to the same value. If the */ +/* > eigenvalues cannot be reordered to compute RCONDV(j), */ +/* > RCONDV(j) is set to 0; this can only occur when the true */ +/* > value would be very small anyway. */ +/* > If SENSE = 'N' or 'E', RCONDV is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,2*N). */ +/* > If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', */ +/* > LWORK >= f2cmax(1,6*N). */ +/* > If SENSE = 'E' or 'B', LWORK >= f2cmax(1,10*N). */ +/* > If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N+6) */ +/* > If SENSE = 'E', IWORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BWORK */ +/* > \verbatim */ +/* > BWORK is LOGICAL array, dimension (N) */ +/* > If SENSE = 'N', BWORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. No eigenvectors have been */ +/* > calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* > should be correct for j=INFO+1,...,N. */ +/* > > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* > =N+2: error return from DTGEVC. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleGEeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Balancing a matrix pair (A,B) includes, first, permuting rows and */ +/* > columns to isolate eigenvalues, second, applying diagonal similarity */ +/* > transformation to the rows and columns to make the rows and columns */ +/* > as close in norm as possible. The computed reciprocal condition */ +/* > numbers correspond to the balanced matrix. Permuting rows and columns */ +/* > will not change the condition numbers (in exact arithmetic) but */ +/* > diagonal scaling will. For further explanation of balancing, see */ +/* > section 4.11.1.2 of LAPACK Users' Guide. */ +/* > */ +/* > An approximate error bound on the chordal distance between the i-th */ +/* > computed generalized eigenvalue w and the corresponding exact */ +/* > eigenvalue lambda is */ +/* > */ +/* > chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */ +/* > */ +/* > An approximate error bound for the angle between the i-th computed */ +/* > eigenvector VL(i) or VR(i) is given by */ +/* > */ +/* > EPS * norm(ABNRM, BBNRM) / DIF(i). */ +/* > */ +/* > For further explanation of the reciprocal condition numbers RCONDE */ +/* > and RCONDV, see section 4.11 of LAPACK User's Guide. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char * + sense, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *alphar, doublereal *alphai, doublereal * + beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, + integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, + doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal * + rcondv, doublereal *work, integer *lwork, integer *iwork, logical * + bwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + logical pair; + doublereal anrm, bnrm; + integer ierr, itau; + doublereal temp; + logical ilvl, ilvr; + integer iwrk, iwrk1, i__, j, m; + extern logical lsame_(char *, char *); + integer icols; + logical noscl; + integer irows; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + integer jc; + extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *), dggbal_(char *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *); + integer in; + extern doublereal dlamch_(char *); + integer mm; + extern doublereal dlange_(char *, integer *, integer *, doublereal *, + integer *, doublereal *); + integer jr; + extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + logical ldumma[1]; + char chtemp[1]; + doublereal bignum; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), dlaset_(char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *); + integer ijobvl; + extern /* Subroutine */ int dtgevc_(char *, char *, logical *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, + doublereal *, integer *), dtgsna_(char *, char *, + logical *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ijobvr; + logical wantsb; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal anrmto; + logical wantse; + doublereal bnrmto; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer minwrk, maxwrk; + logical wantsn; + doublereal smlnum; + logical lquery, wantsv; + doublereal eps; + logical ilv; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --lscale; + --rscale; + --rconde; + --rcondv; + --work; + --iwork; + --bwork; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = FALSE_; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = TRUE_; + } else { + ijobvl = -1; + ilvl = FALSE_; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = FALSE_; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = TRUE_; + } else { + ijobvr = -1; + ilvr = FALSE_; + } + ilv = ilvl || ilvr; + + noscl = lsame_(balanc, "N") || lsame_(balanc, "P"); + wantsn = lsame_(sense, "N"); + wantse = lsame_(sense, "E"); + wantsv = lsame_(sense, "V"); + wantsb = lsame_(sense, "B"); + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") + || lsame_(balanc, "B"))) { + *info = -1; + } else if (ijobvl <= 0) { + *info = -2; + } else if (ijobvr <= 0) { + *info = -3; + } else if (! (wantsn || wantse || wantsb || wantsv)) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -14; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -16; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. The workspace is */ +/* computed assuming ILO = 1 and IHI = N, the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + if (noscl && ! ilv) { + minwrk = *n << 1; + } else { + minwrk = *n * 6; + } + if (wantse || wantsb) { + minwrk = *n * 10; + } + if (wantsv || wantsb) { +/* Computing MAX */ + i__1 = minwrk, i__2 = (*n << 1) * (*n + 4) + 16; + minwrk = f2cmax(i__1,i__2); + } + maxwrk = minwrk; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & + c__1, n, &c__0, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORMQR", " ", n, & + c__1, n, &c__0, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + if (ilvl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", n, &c__1, n, &c__0, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + } + } + work[1] = (doublereal) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -26; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGEVX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute and/or balance the matrix pair (A,B) */ +/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */ + + dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, & + lscale[1], &rscale[1], &work[1], &ierr); + +/* Compute ABNRM and BBNRM */ + + *abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]); + if (ilascl) { + work[1] = *abnrm; + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], & + c__1, &ierr); + *abnrm = work[1]; + } + + *bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]); + if (ilbscl) { + work[1] = *bbnrm; + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], & + c__1, &ierr); + *bbnrm = work[1]; + } + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB ) */ + + irows = *ihi + 1 - *ilo; + if (ilv || ! wantsn) { + icols = *n + 1 - *ilo; + } else { + icols = irows; + } + itau = 1; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, & + work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VL and/or VR */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvl) { + dlaset_("Full", n, n, &c_b59, &c_b60, &vl[vl_offset], ldvl) + ; + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[ + *ilo + 1 + *ilo * vl_dim1], ldvl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, & + work[itau], &work[iwrk], &i__1, &ierr); + } + + if (ilvr) { + dlaset_("Full", n, n, &c_b59, &c_b60, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + if (ilv || ! wantsn) { + +/* Eigenvectors requested -- work on whole matrix. */ + + dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); + } else { + dgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1], + lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &ierr); + } + +/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */ +/* Schur forms and Schur vectors) */ +/* (Workspace: need N) */ + + if (ilv || ! wantsn) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + + dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset] + , ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, & + vr[vr_offset], ldvr, &work[1], lwork, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L130; + } + +/* Compute Eigenvectors and estimate condition numbers if desired */ +/* (Workspace: DTGEVC: need 6*N */ +/* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */ +/* need N otherwise ) */ + + if (ilv || ! wantsn) { + if (ilv) { + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + + dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, & + work[1], &ierr); + if (ierr != 0) { + *info = *n + 2; + goto L130; + } + } + + if (! wantsn) { + +/* compute eigenvectors (DTGEVC) and estimate condition */ +/* numbers (DTGSNA). Note that the definition of the condition */ +/* number is not invariant under transformation (u,v) to */ +/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */ +/* Schur form (S,T), Q and Z are orthogonal matrices. In order */ +/* to avoid using extra 2*N*N workspace, we have to recalculate */ +/* eigenvectors and estimate one condition numbers at a time. */ + + pair = FALSE_; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (pair) { + pair = FALSE_; + goto L20; + } + mm = 1; + if (i__ < *n) { + if (a[i__ + 1 + i__ * a_dim1] != 0.) { + pair = TRUE_; + mm = 2; + } + } + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + bwork[j] = FALSE_; +/* L10: */ + } + if (mm == 1) { + bwork[i__] = TRUE_; + } else if (mm == 2) { + bwork[i__] = TRUE_; + bwork[i__ + 1] = TRUE_; + } + + iwrk = mm * *n + 1; + iwrk1 = iwrk + mm * *n; + +/* Compute a pair of left and right eigenvectors. */ +/* (compute workspace: need up to 4*N + 6*N) */ + + if (wantse || wantsb) { + dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &work[1], n, &work[iwrk], n, &mm, + &m, &work[iwrk1], &ierr); + if (ierr != 0) { + *info = *n + 2; + goto L130; + } + } + + i__2 = *lwork - iwrk1 + 1; + dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[ + i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, & + iwork[1], &ierr); + +L20: + ; + } + } + } + +/* Undo balancing on VL and VR and normalization */ +/* (Workspace: none needed) */ + + if (ilvl) { + dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[ + vl_offset], ldvl, &ierr); + + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L70; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], abs( + d__1)); + temp = f2cmax(d__2,d__3); +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], abs( + d__1)) + (d__2 = vl[jr + (jc + 1) * vl_dim1], abs( + d__2)); + temp = f2cmax(d__3,d__4); +/* L40: */ + } + } + if (temp < smlnum) { + goto L70; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L50: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L60: */ + } + } +L70: + ; + } + } + if (ilvr) { + dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[ + vr_offset], ldvr, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L120; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], abs( + d__1)); + temp = f2cmax(d__2,d__3); +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], abs( + d__1)) + (d__2 = vr[jr + (jc + 1) * vr_dim1], abs( + d__2)); + temp = f2cmax(d__3,d__4); +/* L90: */ + } + } + if (temp < smlnum) { + goto L120; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L100: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L110: */ + } + } +L120: + ; + } + } + +/* Undo scaling if necessary */ + +L130: + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + work[1] = (doublereal) maxwrk; + return 0; + +/* End of DGGEVX */ + +} /* dggevx_ */ + diff --git a/lapack-netlib/SRC/dggglm.c b/lapack-netlib/SRC/dggglm.c new file mode 100644 index 000000000..676fc7180 --- /dev/null +++ b/lapack-netlib/SRC/dggglm.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 DGGGLM */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGGLM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LWORK, M, N, P */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), */ +/* $ X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGGLM solves a general Gauss-Markov linear model (GLM) problem: */ +/* > */ +/* > minimize || y ||_2 subject to d = A*x + B*y */ +/* > x */ +/* > */ +/* > where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */ +/* > given N-vector. It is assumed that M <= N <= M+P, and */ +/* > */ +/* > rank(A) = M and rank( A B ) = N. */ +/* > */ +/* > Under these assumptions, the constrained equation is always */ +/* > consistent, and there is a unique solution x and a minimal 2-norm */ +/* > solution y, which is obtained using a generalized QR factorization */ +/* > of the matrices (A, B) given by */ +/* > */ +/* > A = Q*(R), B = Q*T*Z. */ +/* > (0) */ +/* > */ +/* > In particular, if matrix B is square nonsingular, then the problem */ +/* > GLM is equivalent to the following weighted linear least squares */ +/* > problem */ +/* > */ +/* > minimize || inv(B)*(d-A*x) ||_2 */ +/* > x */ +/* > */ +/* > where inv(B) denotes the inverse of B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns of the matrix A. 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of columns of the matrix B. P >= N-M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,M) */ +/* > On entry, the N-by-M matrix A. */ +/* > On exit, the upper triangular part of the array A contains */ +/* > the M-by-M upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,P) */ +/* > On entry, the N-by-P matrix B. */ +/* > On exit, if N <= P, the upper triangle of the subarray */ +/* > B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ +/* > if N > P, the elements on and above the (N-P)th subdiagonal */ +/* > contain the N-by-P upper trapezoidal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, D is the left hand side of the GLM equation. */ +/* > On exit, D is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension (P) */ +/* > */ +/* > On exit, X and Y are the solutions of the GLM problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N+M+P). */ +/* > For optimum performance, LWORK >= M+f2cmin(N,P)+f2cmax(N,P)*NB, */ +/* > where NB is an upper bound for the optimal blocksizes for */ +/* > DGEQRF, SGERQF, DORMQR and SORMRQ. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1: the upper triangular factor R associated with A in the */ +/* > generalized QR factorization of the pair (A, B) is */ +/* > singular, so that rank(A) < M; the least squares */ +/* > solution could not be computed. */ +/* > = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */ +/* > factor T associated with B in the generalized QR */ +/* > factorization of the pair (A, B) is singular, so that */ +/* > rank( A B ) < N; the least squares solution could not */ +/* > be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, doublereal * + a, integer *lda, doublereal *b, integer *ldb, doublereal *d__, + doublereal *x, doublereal *y, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer lopt, i__; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *); + integer nb, np; + extern /* Subroutine */ int dggqrf_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer lwkmin, nb1, nb2, nb3, nb4; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), + dormrq_(char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* =================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --d__; + --x; + --y; + --work; + + /* Function Body */ + *info = 0; + np = f2cmin(*n,*p); + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*m < 0 || *m > *n) { + *info = -2; + } else if (*p < 0 || *p < *n - *m) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + +/* Calculate workspace */ + + if (*info == 0) { + if (*n == 0) { + lwkmin = 1; + lwkopt = 1; + } else { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + nb2 = ilaenv_(&c__1, "DGERQF", " ", n, m, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb4 = ilaenv_(&c__1, "DORMRQ", " ", n, m, p, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2), i__1 = f2cmax(i__1,nb3); + nb = f2cmax(i__1,nb4); + lwkmin = *m + *n + *p; + lwkopt = *m + np + f2cmax(*n,*p) * nb; + } + work[1] = (doublereal) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGGLM", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 0.; + } + i__1 = *p; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; + } + return 0; + } + +/* Compute the GQR factorization of matrices A and B: */ + +/* Q**T*A = ( R11 ) M, Q**T*B*Z**T = ( T11 T12 ) M */ +/* ( 0 ) N-M ( 0 T22 ) N-M */ +/* M M+P-N N-M */ + +/* where R11 and T22 are upper triangular, and Q and Z are */ +/* orthogonal. */ + + i__1 = *lwork - *m - np; + dggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m + + 1], &work[*m + np + 1], &i__1, info); + lopt = (integer) work[*m + np + 1]; + +/* Update left-hand-side vector d = Q**T*d = ( d1 ) M */ +/* ( d2 ) N-M */ + + i__1 = f2cmax(1,*n); + i__2 = *lwork - *m - np; + dormqr_("Left", "Transpose", n, &c__1, m, &a[a_offset], lda, &work[1], & + d__[1], &i__1, &work[*m + np + 1], &i__2, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*m + np + 1]; + lopt = f2cmax(i__1,i__2); + +/* Solve T22*y2 = d2 for y2 */ + + if (*n > *m) { + i__1 = *n - *m; + i__2 = *n - *m; + dtrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1 + + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2, + info); + + if (*info > 0) { + *info = 1; + return 0; + } + + i__1 = *n - *m; + dcopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1); + } + +/* Set y1 = 0 */ + + i__1 = *m + *p - *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + +/* Update d1 = d1 - T12*y2 */ + + i__1 = *n - *m; + dgemv_("No transpose", m, &i__1, &c_b32, &b[(*m + *p - *n + 1) * b_dim1 + + 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1); + +/* Solve triangular system: R11*x = d1 */ + + if (*m > 0) { + dtrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset], + lda, &d__[1], m, info); + + if (*info > 0) { + *info = 2; + return 0; + } + +/* Copy D to X */ + + dcopy_(m, &d__[1], &c__1, &x[1], &c__1); + } + +/* Backward transformation y = Z**T *y */ + +/* Computing MAX */ + i__1 = 1, i__2 = *n - *p + 1; + i__3 = f2cmax(1,*p); + i__4 = *lwork - *m - np; + dormrq_("Left", "Transpose", p, &c__1, &np, &b[f2cmax(i__1,i__2) + b_dim1], + ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &i__4, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*m + np + 1]; + work[1] = (doublereal) (*m + np + f2cmax(i__1,i__2)); + + return 0; + +/* End of DGGGLM */ + +} /* dggglm_ */ + diff --git a/lapack-netlib/SRC/dgghd3.c b/lapack-netlib/SRC/dgghd3.c new file mode 100644 index 000000000..5dacc029a --- /dev/null +++ b/lapack-netlib/SRC/dgghd3.c @@ -0,0 +1,1457 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGGHD3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGHD3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, */ +/* LDQ, Z, LDZ, WORK, LWORK, INFO ) */ + +/* CHARACTER COMPQ, COMPZ */ +/* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ Z( LDZ, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGHD3 reduces a pair of real matrices (A,B) to generalized upper */ +/* > Hessenberg form using orthogonal transformations, where A is a */ +/* > general matrix and B is upper triangular. The form of the */ +/* > generalized eigenvalue problem is */ +/* > A*x = lambda*B*x, */ +/* > and B is typically made upper triangular by computing its QR */ +/* > factorization and moving the orthogonal matrix Q to the left side */ +/* > of the equation. */ +/* > */ +/* > This subroutine simultaneously reduces A to a Hessenberg matrix H: */ +/* > Q**T*A*Z = H */ +/* > and transforms B to another upper triangular matrix T: */ +/* > Q**T*B*Z = T */ +/* > in order to reduce the problem to its standard form */ +/* > H*y = lambda*T*y */ +/* > where y = Z**T*x. */ +/* > */ +/* > The orthogonal matrices Q and Z are determined as products of Givens */ +/* > rotations. They may either be formed explicitly, or they may be */ +/* > postmultiplied into input matrices Q1 and Z1, so that */ +/* > */ +/* > Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T */ +/* > */ +/* > Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T */ +/* > */ +/* > If Q1 is the orthogonal matrix from the QR factorization of B in the */ +/* > original equation A*x = lambda*B*x, then DGGHD3 reduces the original */ +/* > problem to generalized Hessenberg form. */ +/* > */ +/* > This is a blocked variant of DGGHRD, using matrix-matrix */ +/* > multiplications for parts of the computation to enhance performance. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'N': do not compute Q; */ +/* > = 'I': Q is initialized to the unit matrix, and the */ +/* > orthogonal matrix Q is returned; */ +/* > = 'V': Q must contain an orthogonal matrix Q1 on entry, */ +/* > and the product Q1*Q is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': do not compute Z; */ +/* > = 'I': Z is initialized to the unit matrix, and the */ +/* > orthogonal matrix Z is returned; */ +/* > = 'V': Z must contain an orthogonal matrix Z1 on entry, */ +/* > and the product Z1*Z is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > ILO and IHI mark the rows and columns of A which are to be */ +/* > reduced. It is assumed that A is already upper triangular */ +/* > in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */ +/* > normally set by a previous call to DGGBAL; otherwise they */ +/* > should be set to 1 and N respectively. */ +/* > 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the N-by-N general matrix to be reduced. */ +/* > On exit, the upper triangle and the first subdiagonal of A */ +/* > are overwritten with the upper Hessenberg matrix H, and the */ +/* > rest is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the N-by-N upper triangular matrix B. */ +/* > On exit, the upper triangular matrix T = Q**T B Z. The */ +/* > elements below the diagonal are set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */ +/* > On entry, if COMPQ = 'V', the orthogonal matrix Q1, */ +/* > typically from the QR factorization of B. */ +/* > On exit, if COMPQ='I', the orthogonal matrix Q, and if */ +/* > COMPQ = 'V', the product Q1*Q. */ +/* > Not referenced if COMPQ='N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', the orthogonal matrix Z1. */ +/* > On exit, if COMPZ='I', the orthogonal matrix Z, and if */ +/* > COMPZ = 'V', the product Z1*Z. */ +/* > Not referenced if COMPZ='N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. */ +/* > LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= 1. */ +/* > For optimum performance LWORK >= 6*N*NB, where NB is the */ +/* > optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date January 2015 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine reduces A to Hessenberg form and maintains B in */ +/* > using a blocked variant of Moler and Stewart's original algorithm, */ +/* > as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti */ +/* > (BIT 2008). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dgghd3_(char *compq, char *compz, integer *n, integer * + ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *q, integer *ldq, doublereal *z__, integer * + ldz, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + doublereal d__1; + + /* Local variables */ + logical blk22; + integer cola, jcol, ierr; + doublereal temp; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer jrow, topq, ppwo; + doublereal temp1, temp2, temp3, c__; + integer kacc22, i__, j, k; + doublereal s; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer nbmin; + extern /* Subroutine */ int dorm22_(char *, char *, integer *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer nblst; + logical initq; + doublereal c1, c2; + logical wantq; + integer j0; + extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *); + logical initz, wantz; + doublereal s1, s2; + char compq2[1], compz2[1]; + integer nb, jj, nh; + extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *); + integer nx, pw; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + integer nnb, len, top, ppw, n2nb; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* January 2015 */ + + + +/* ===================================================================== */ + + +/* Decode and test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "DGGHD3", " ", n, ilo, ihi, &c_n1, (ftnlen)6, (ftnlen) + 1); +/* Computing MAX */ + i__1 = *n * 6 * nb; + lwkopt = f2cmax(i__1,1); + work[1] = (doublereal) lwkopt; + initq = lsame_(compq, "I"); + wantq = initq || lsame_(compq, "V"); + initz = lsame_(compz, "I"); + wantz = initz || lsame_(compz, "V"); + lquery = *lwork == -1; + + if (! lsame_(compq, "N") && ! wantq) { + *info = -1; + } else if (! lsame_(compz, "N") && ! wantz) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1) { + *info = -4; + } else if (*ihi > *n || *ihi < *ilo - 1) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (wantq && *ldq < *n || *ldq < 1) { + *info = -11; + } else if (wantz && *ldz < *n || *ldz < 1) { + *info = -13; + } else if (*lwork < 1 && ! lquery) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGHD3", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Initialize Q and Z if desired. */ + + if (initq) { + dlaset_("All", n, n, &c_b14, &c_b15, &q[q_offset], ldq); + } + if (initz) { + dlaset_("All", n, n, &c_b14, &c_b15, &z__[z_offset], ldz); + } + +/* Zero out lower triangle of B. */ + + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_("Lower", &i__1, &i__2, &c_b14, &c_b14, &b[b_dim1 + 2], ldb); + } + +/* Quick return if possible */ + + nh = *ihi - *ilo + 1; + if (nh <= 1) { + work[1] = 1.; + return 0; + } + +/* Determine the blocksize. */ + + nbmin = ilaenv_(&c__2, "DGGHD3", " ", n, ilo, ihi, &c_n1, (ftnlen)6, ( + ftnlen)1); + if (nb > 1 && nb < nh) { + +/* Determine when to use unblocked instead of blocked code. */ + +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__3, "DGGHD3", " ", n, ilo, ihi, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < nh) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal NB: determine the */ +/* minimum value of NB, and reduce NB or force use of */ +/* unblocked code. */ + +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGGHD3", " ", n, ilo, ihi, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + if (*lwork >= *n * 6 * nbmin) { + nb = *lwork / (*n * 6); + } else { + nb = 1; + } + } + } + } + + if (nb < nbmin || nb >= nh) { + +/* Use unblocked code below */ + + jcol = *ilo; + + } else { + +/* Use blocked code */ + + kacc22 = ilaenv_(&c__16, "DGGHD3", " ", n, ilo, ihi, &c_n1, (ftnlen)6, + (ftnlen)1); + blk22 = kacc22 == 2; + i__1 = *ihi - 2; + i__2 = nb; + for (jcol = *ilo; i__2 < 0 ? jcol >= i__1 : jcol <= i__1; jcol += + i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *ihi - jcol - 1; + nnb = f2cmin(i__3,i__4); + +/* Initialize small orthogonal factors that will hold the */ +/* accumulated Givens rotations in workspace. */ +/* N2NB denotes the number of 2*NNB-by-2*NNB factors */ +/* NBLST denotes the (possibly smaller) order of the last */ +/* factor. */ + + n2nb = (*ihi - jcol - 1) / nnb - 1; + nblst = *ihi - jcol - n2nb * nnb; + dlaset_("All", &nblst, &nblst, &c_b14, &c_b15, &work[1], &nblst); + pw = nblst * nblst + 1; + i__3 = n2nb; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = nnb << 1; + i__5 = nnb << 1; + i__6 = nnb << 1; + dlaset_("All", &i__4, &i__5, &c_b14, &c_b15, &work[pw], &i__6); + pw += (nnb << 2) * nnb; + } + +/* Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form. */ + + i__3 = jcol + nnb - 1; + for (j = jcol; j <= i__3; ++j) { + +/* Reduce Jth column of A. Store cosines and sines in Jth */ +/* column of A and B, respectively. */ + + i__4 = j + 2; + for (i__ = *ihi; i__ >= i__4; --i__) { + temp = a[i__ - 1 + j * a_dim1]; + dlartg_(&temp, &a[i__ + j * a_dim1], &c__, &s, &a[i__ - 1 + + j * a_dim1]); + a[i__ + j * a_dim1] = c__; + b[i__ + j * b_dim1] = s; + } + +/* Accumulate Givens rotations into workspace array. */ + + ppw = (nblst + 1) * (nblst - 2) - j + jcol + 1; + len = j + 2 - jcol; + jrow = j + n2nb * nnb + 2; + i__4 = jrow; + for (i__ = *ihi; i__ >= i__4; --i__) { + c__ = a[i__ + j * a_dim1]; + s = b[i__ + j * b_dim1]; + i__5 = ppw + len - 1; + for (jj = ppw; jj <= i__5; ++jj) { + temp = work[jj + nblst]; + work[jj + nblst] = c__ * temp - s * work[jj]; + work[jj] = s * temp + c__ * work[jj]; + } + ++len; + ppw = ppw - nblst - 1; + } + + ppwo = nblst * nblst + (nnb + j - jcol - 1 << 1) * nnb + nnb; + j0 = jrow - nnb; + i__4 = j + 2; + i__5 = -nnb; + for (jrow = j0; i__5 < 0 ? jrow >= i__4 : jrow <= i__4; jrow + += i__5) { + ppw = ppwo; + len = j + 2 - jcol; + i__6 = jrow; + for (i__ = jrow + nnb - 1; i__ >= i__6; --i__) { + c__ = a[i__ + j * a_dim1]; + s = b[i__ + j * b_dim1]; + i__7 = ppw + len - 1; + for (jj = ppw; jj <= i__7; ++jj) { + temp = work[jj + (nnb << 1)]; + work[jj + (nnb << 1)] = c__ * temp - s * work[jj]; + work[jj] = s * temp + c__ * work[jj]; + } + ++len; + ppw = ppw - (nnb << 1) - 1; + } + ppwo += (nnb << 2) * nnb; + } + +/* TOP denotes the number of top rows in A and B that will */ +/* not be updated during the next steps. */ + + if (jcol <= 2) { + top = 0; + } else { + top = jcol; + } + +/* Propagate transformations through B and replace stored */ +/* left sines/cosines by right sines/cosines. */ + + i__5 = j + 1; + for (jj = *n; jj >= i__5; --jj) { + +/* Update JJth column of B. */ + +/* Computing MIN */ + i__4 = jj + 1; + i__6 = j + 2; + for (i__ = f2cmin(i__4,*ihi); i__ >= i__6; --i__) { + c__ = a[i__ + j * a_dim1]; + s = b[i__ + j * b_dim1]; + temp = b[i__ + jj * b_dim1]; + b[i__ + jj * b_dim1] = c__ * temp - s * b[i__ - 1 + + jj * b_dim1]; + b[i__ - 1 + jj * b_dim1] = s * temp + c__ * b[i__ - 1 + + jj * b_dim1]; + } + +/* Annihilate B( JJ+1, JJ ). */ + + if (jj < *ihi) { + temp = b[jj + 1 + (jj + 1) * b_dim1]; + dlartg_(&temp, &b[jj + 1 + jj * b_dim1], &c__, &s, &b[ + jj + 1 + (jj + 1) * b_dim1]); + b[jj + 1 + jj * b_dim1] = 0.; + i__6 = jj - top; + drot_(&i__6, &b[top + 1 + (jj + 1) * b_dim1], &c__1, & + b[top + 1 + jj * b_dim1], &c__1, &c__, &s); + a[jj + 1 + j * a_dim1] = c__; + b[jj + 1 + j * b_dim1] = -s; + } + } + +/* Update A by transformations from right. */ +/* Explicit loop unrolling provides better performance */ +/* compared to DLASR. */ +/* CALL DLASR( 'Right', 'Variable', 'Backward', IHI-TOP, */ +/* $ IHI-J, A( J+2, J ), B( J+2, J ), */ +/* $ A( TOP+1, J+1 ), LDA ) */ + + jj = (*ihi - j - 1) % 3; + i__5 = jj + 1; + for (i__ = *ihi - j - 3; i__ >= i__5; i__ += -3) { + c__ = a[j + 1 + i__ + j * a_dim1]; + s = -b[j + 1 + i__ + j * b_dim1]; + c1 = a[j + 2 + i__ + j * a_dim1]; + s1 = -b[j + 2 + i__ + j * b_dim1]; + c2 = a[j + 3 + i__ + j * a_dim1]; + s2 = -b[j + 3 + i__ + j * b_dim1]; + + i__6 = *ihi; + for (k = top + 1; k <= i__6; ++k) { + temp = a[k + (j + i__) * a_dim1]; + temp1 = a[k + (j + i__ + 1) * a_dim1]; + temp2 = a[k + (j + i__ + 2) * a_dim1]; + temp3 = a[k + (j + i__ + 3) * a_dim1]; + a[k + (j + i__ + 3) * a_dim1] = c2 * temp3 + s2 * + temp2; + temp2 = -s2 * temp3 + c2 * temp2; + a[k + (j + i__ + 2) * a_dim1] = c1 * temp2 + s1 * + temp1; + temp1 = -s1 * temp2 + c1 * temp1; + a[k + (j + i__ + 1) * a_dim1] = c__ * temp1 + s * + temp; + a[k + (j + i__) * a_dim1] = -s * temp1 + c__ * temp; + } + } + + if (jj > 0) { + for (i__ = jj; i__ >= 1; --i__) { + i__5 = *ihi - top; + d__1 = -b[j + 1 + i__ + j * b_dim1]; + drot_(&i__5, &a[top + 1 + (j + i__ + 1) * a_dim1], & + c__1, &a[top + 1 + (j + i__) * a_dim1], &c__1, + &a[j + 1 + i__ + j * a_dim1], &d__1); + } + } + +/* Update (J+1)th column of A by transformations from left. */ + + if (j < jcol + nnb - 1) { + len = j + 1 - jcol; + +/* Multiply with the trailing accumulated orthogonal */ +/* matrix, which takes the form */ + +/* [ U11 U12 ] */ +/* U = [ ], */ +/* [ U21 U22 ] */ + +/* where U21 is a LEN-by-LEN matrix and U12 is lower */ +/* triangular. */ + + jrow = *ihi - nblst + 1; + dgemv_("Transpose", &nblst, &len, &c_b15, &work[1], & + nblst, &a[jrow + (j + 1) * a_dim1], &c__1, &c_b14, + &work[pw], &c__1); + ppw = pw + len; + i__5 = jrow + nblst - len - 1; + for (i__ = jrow; i__ <= i__5; ++i__) { + work[ppw] = a[i__ + (j + 1) * a_dim1]; + ++ppw; + } + i__5 = nblst - len; + dtrmv_("Lower", "Transpose", "Non-unit", &i__5, &work[len + * nblst + 1], &nblst, &work[pw + len], &c__1); + i__5 = nblst - len; + dgemv_("Transpose", &len, &i__5, &c_b15, &work[(len + 1) * + nblst - len + 1], &nblst, &a[jrow + nblst - len + + (j + 1) * a_dim1], &c__1, &c_b15, &work[pw + + len], &c__1); + ppw = pw; + i__5 = jrow + nblst - 1; + for (i__ = jrow; i__ <= i__5; ++i__) { + a[i__ + (j + 1) * a_dim1] = work[ppw]; + ++ppw; + } + +/* Multiply with the other accumulated orthogonal */ +/* matrices, which take the form */ + +/* [ U11 U12 0 ] */ +/* [ ] */ +/* U = [ U21 U22 0 ], */ +/* [ ] */ +/* [ 0 0 I ] */ + +/* where I denotes the (NNB-LEN)-by-(NNB-LEN) identity */ +/* matrix, U21 is a LEN-by-LEN upper triangular matrix */ +/* and U12 is an NNB-by-NNB lower triangular matrix. */ + + ppwo = nblst * nblst + 1; + j0 = jrow - nnb; + i__5 = jcol + 1; + i__6 = -nnb; + for (jrow = j0; i__6 < 0 ? jrow >= i__5 : jrow <= i__5; + jrow += i__6) { + ppw = pw + len; + i__4 = jrow + nnb - 1; + for (i__ = jrow; i__ <= i__4; ++i__) { + work[ppw] = a[i__ + (j + 1) * a_dim1]; + ++ppw; + } + ppw = pw; + i__4 = jrow + nnb + len - 1; + for (i__ = jrow + nnb; i__ <= i__4; ++i__) { + work[ppw] = a[i__ + (j + 1) * a_dim1]; + ++ppw; + } + i__4 = nnb << 1; + dtrmv_("Upper", "Transpose", "Non-unit", &len, &work[ + ppwo + nnb], &i__4, &work[pw], &c__1); + i__4 = nnb << 1; + dtrmv_("Lower", "Transpose", "Non-unit", &nnb, &work[ + ppwo + (len << 1) * nnb], &i__4, &work[pw + + len], &c__1); + i__4 = nnb << 1; + dgemv_("Transpose", &nnb, &len, &c_b15, &work[ppwo], & + i__4, &a[jrow + (j + 1) * a_dim1], &c__1, & + c_b15, &work[pw], &c__1); + i__4 = nnb << 1; + dgemv_("Transpose", &len, &nnb, &c_b15, &work[ppwo + ( + len << 1) * nnb + nnb], &i__4, &a[jrow + nnb + + (j + 1) * a_dim1], &c__1, &c_b15, &work[pw + + len], &c__1); + ppw = pw; + i__4 = jrow + len + nnb - 1; + for (i__ = jrow; i__ <= i__4; ++i__) { + a[i__ + (j + 1) * a_dim1] = work[ppw]; + ++ppw; + } + ppwo += (nnb << 2) * nnb; + } + } + } + +/* Apply accumulated orthogonal matrices to A. */ + + cola = *n - jcol - nnb + 1; + j = *ihi - nblst + 1; + dgemm_("Transpose", "No Transpose", &nblst, &cola, &nblst, &c_b15, + &work[1], &nblst, &a[j + (jcol + nnb) * a_dim1], lda, & + c_b14, &work[pw], &nblst); + dlacpy_("All", &nblst, &cola, &work[pw], &nblst, &a[j + (jcol + + nnb) * a_dim1], lda); + ppwo = nblst * nblst + 1; + j0 = j - nnb; + i__3 = jcol + 1; + i__6 = -nnb; + for (j = j0; i__6 < 0 ? j >= i__3 : j <= i__3; j += i__6) { + if (blk22) { + +/* Exploit the structure of */ + +/* [ U11 U12 ] */ +/* U = [ ] */ +/* [ U21 U22 ], */ + +/* where all blocks are NNB-by-NNB, U21 is upper */ +/* triangular and U12 is lower triangular. */ + + i__5 = nnb << 1; + i__4 = nnb << 1; + i__7 = *lwork - pw + 1; + dorm22_("Left", "Transpose", &i__5, &cola, &nnb, &nnb, & + work[ppwo], &i__4, &a[j + (jcol + nnb) * a_dim1], + lda, &work[pw], &i__7, &ierr); + } else { + +/* Ignore the structure of U. */ + + i__5 = nnb << 1; + i__4 = nnb << 1; + i__7 = nnb << 1; + i__8 = nnb << 1; + dgemm_("Transpose", "No Transpose", &i__5, &cola, &i__4, & + c_b15, &work[ppwo], &i__7, &a[j + (jcol + nnb) * + a_dim1], lda, &c_b14, &work[pw], &i__8); + i__5 = nnb << 1; + i__4 = nnb << 1; + dlacpy_("All", &i__5, &cola, &work[pw], &i__4, &a[j + ( + jcol + nnb) * a_dim1], lda); + } + ppwo += (nnb << 2) * nnb; + } + +/* Apply accumulated orthogonal matrices to Q. */ + + if (wantq) { + j = *ihi - nblst + 1; + if (initq) { +/* Computing MAX */ + i__6 = 2, i__3 = j - jcol + 1; + topq = f2cmax(i__6,i__3); + nh = *ihi - topq + 1; + } else { + topq = 1; + nh = *n; + } + dgemm_("No Transpose", "No Transpose", &nh, &nblst, &nblst, & + c_b15, &q[topq + j * q_dim1], ldq, &work[1], &nblst, & + c_b14, &work[pw], &nh); + dlacpy_("All", &nh, &nblst, &work[pw], &nh, &q[topq + j * + q_dim1], ldq); + ppwo = nblst * nblst + 1; + j0 = j - nnb; + i__6 = jcol + 1; + i__3 = -nnb; + for (j = j0; i__3 < 0 ? j >= i__6 : j <= i__6; j += i__3) { + if (initq) { +/* Computing MAX */ + i__5 = 2, i__4 = j - jcol + 1; + topq = f2cmax(i__5,i__4); + nh = *ihi - topq + 1; + } + if (blk22) { + +/* Exploit the structure of U. */ + + i__5 = nnb << 1; + i__4 = nnb << 1; + i__7 = *lwork - pw + 1; + dorm22_("Right", "No Transpose", &nh, &i__5, &nnb, & + nnb, &work[ppwo], &i__4, &q[topq + j * q_dim1] + , ldq, &work[pw], &i__7, &ierr); + } else { + +/* Ignore the structure of U. */ + + i__5 = nnb << 1; + i__4 = nnb << 1; + i__7 = nnb << 1; + dgemm_("No Transpose", "No Transpose", &nh, &i__5, & + i__4, &c_b15, &q[topq + j * q_dim1], ldq, & + work[ppwo], &i__7, &c_b14, &work[pw], &nh); + i__5 = nnb << 1; + dlacpy_("All", &nh, &i__5, &work[pw], &nh, &q[topq + + j * q_dim1], ldq); + } + ppwo += (nnb << 2) * nnb; + } + } + +/* Accumulate right Givens rotations if required. */ + + if (wantz || top > 0) { + +/* Initialize small orthogonal factors that will hold the */ +/* accumulated Givens rotations in workspace. */ + + dlaset_("All", &nblst, &nblst, &c_b14, &c_b15, &work[1], & + nblst); + pw = nblst * nblst + 1; + i__3 = n2nb; + for (i__ = 1; i__ <= i__3; ++i__) { + i__6 = nnb << 1; + i__5 = nnb << 1; + i__4 = nnb << 1; + dlaset_("All", &i__6, &i__5, &c_b14, &c_b15, &work[pw], & + i__4); + pw += (nnb << 2) * nnb; + } + +/* Accumulate Givens rotations into workspace array. */ + + i__3 = jcol + nnb - 1; + for (j = jcol; j <= i__3; ++j) { + ppw = (nblst + 1) * (nblst - 2) - j + jcol + 1; + len = j + 2 - jcol; + jrow = j + n2nb * nnb + 2; + i__6 = jrow; + for (i__ = *ihi; i__ >= i__6; --i__) { + c__ = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = 0.; + s = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = 0.; + i__5 = ppw + len - 1; + for (jj = ppw; jj <= i__5; ++jj) { + temp = work[jj + nblst]; + work[jj + nblst] = c__ * temp - s * work[jj]; + work[jj] = s * temp + c__ * work[jj]; + } + ++len; + ppw = ppw - nblst - 1; + } + + ppwo = nblst * nblst + (nnb + j - jcol - 1 << 1) * nnb + + nnb; + j0 = jrow - nnb; + i__6 = j + 2; + i__5 = -nnb; + for (jrow = j0; i__5 < 0 ? jrow >= i__6 : jrow <= i__6; + jrow += i__5) { + ppw = ppwo; + len = j + 2 - jcol; + i__4 = jrow; + for (i__ = jrow + nnb - 1; i__ >= i__4; --i__) { + c__ = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = 0.; + s = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = 0.; + i__7 = ppw + len - 1; + for (jj = ppw; jj <= i__7; ++jj) { + temp = work[jj + (nnb << 1)]; + work[jj + (nnb << 1)] = c__ * temp - s * work[ + jj]; + work[jj] = s * temp + c__ * work[jj]; + } + ++len; + ppw = ppw - (nnb << 1) - 1; + } + ppwo += (nnb << 2) * nnb; + } + } + } else { + + i__3 = *ihi - jcol - 1; + dlaset_("Lower", &i__3, &nnb, &c_b14, &c_b14, &a[jcol + 2 + + jcol * a_dim1], lda); + i__3 = *ihi - jcol - 1; + dlaset_("Lower", &i__3, &nnb, &c_b14, &c_b14, &b[jcol + 2 + + jcol * b_dim1], ldb); + } + +/* Apply accumulated orthogonal matrices to A and B. */ + + if (top > 0) { + j = *ihi - nblst + 1; + dgemm_("No Transpose", "No Transpose", &top, &nblst, &nblst, & + c_b15, &a[j * a_dim1 + 1], lda, &work[1], &nblst, & + c_b14, &work[pw], &top); + dlacpy_("All", &top, &nblst, &work[pw], &top, &a[j * a_dim1 + + 1], lda); + ppwo = nblst * nblst + 1; + j0 = j - nnb; + i__3 = jcol + 1; + i__5 = -nnb; + for (j = j0; i__5 < 0 ? j >= i__3 : j <= i__3; j += i__5) { + if (blk22) { + +/* Exploit the structure of U. */ + + i__6 = nnb << 1; + i__4 = nnb << 1; + i__7 = *lwork - pw + 1; + dorm22_("Right", "No Transpose", &top, &i__6, &nnb, & + nnb, &work[ppwo], &i__4, &a[j * a_dim1 + 1], + lda, &work[pw], &i__7, &ierr); + } else { + +/* Ignore the structure of U. */ + + i__6 = nnb << 1; + i__4 = nnb << 1; + i__7 = nnb << 1; + dgemm_("No Transpose", "No Transpose", &top, &i__6, & + i__4, &c_b15, &a[j * a_dim1 + 1], lda, &work[ + ppwo], &i__7, &c_b14, &work[pw], &top); + i__6 = nnb << 1; + dlacpy_("All", &top, &i__6, &work[pw], &top, &a[j * + a_dim1 + 1], lda); + } + ppwo += (nnb << 2) * nnb; + } + + j = *ihi - nblst + 1; + dgemm_("No Transpose", "No Transpose", &top, &nblst, &nblst, & + c_b15, &b[j * b_dim1 + 1], ldb, &work[1], &nblst, & + c_b14, &work[pw], &top); + dlacpy_("All", &top, &nblst, &work[pw], &top, &b[j * b_dim1 + + 1], ldb); + ppwo = nblst * nblst + 1; + j0 = j - nnb; + i__5 = jcol + 1; + i__3 = -nnb; + for (j = j0; i__3 < 0 ? j >= i__5 : j <= i__5; j += i__3) { + if (blk22) { + +/* Exploit the structure of U. */ + + i__6 = nnb << 1; + i__4 = nnb << 1; + i__7 = *lwork - pw + 1; + dorm22_("Right", "No Transpose", &top, &i__6, &nnb, & + nnb, &work[ppwo], &i__4, &b[j * b_dim1 + 1], + ldb, &work[pw], &i__7, &ierr); + } else { + +/* Ignore the structure of U. */ + + i__6 = nnb << 1; + i__4 = nnb << 1; + i__7 = nnb << 1; + dgemm_("No Transpose", "No Transpose", &top, &i__6, & + i__4, &c_b15, &b[j * b_dim1 + 1], ldb, &work[ + ppwo], &i__7, &c_b14, &work[pw], &top); + i__6 = nnb << 1; + dlacpy_("All", &top, &i__6, &work[pw], &top, &b[j * + b_dim1 + 1], ldb); + } + ppwo += (nnb << 2) * nnb; + } + } + +/* Apply accumulated orthogonal matrices to Z. */ + + if (wantz) { + j = *ihi - nblst + 1; + if (initq) { +/* Computing MAX */ + i__3 = 2, i__5 = j - jcol + 1; + topq = f2cmax(i__3,i__5); + nh = *ihi - topq + 1; + } else { + topq = 1; + nh = *n; + } + dgemm_("No Transpose", "No Transpose", &nh, &nblst, &nblst, & + c_b15, &z__[topq + j * z_dim1], ldz, &work[1], &nblst, + &c_b14, &work[pw], &nh); + dlacpy_("All", &nh, &nblst, &work[pw], &nh, &z__[topq + j * + z_dim1], ldz); + ppwo = nblst * nblst + 1; + j0 = j - nnb; + i__3 = jcol + 1; + i__5 = -nnb; + for (j = j0; i__5 < 0 ? j >= i__3 : j <= i__3; j += i__5) { + if (initq) { +/* Computing MAX */ + i__6 = 2, i__4 = j - jcol + 1; + topq = f2cmax(i__6,i__4); + nh = *ihi - topq + 1; + } + if (blk22) { + +/* Exploit the structure of U. */ + + i__6 = nnb << 1; + i__4 = nnb << 1; + i__7 = *lwork - pw + 1; + dorm22_("Right", "No Transpose", &nh, &i__6, &nnb, & + nnb, &work[ppwo], &i__4, &z__[topq + j * + z_dim1], ldz, &work[pw], &i__7, &ierr); + } else { + +/* Ignore the structure of U. */ + + i__6 = nnb << 1; + i__4 = nnb << 1; + i__7 = nnb << 1; + dgemm_("No Transpose", "No Transpose", &nh, &i__6, & + i__4, &c_b15, &z__[topq + j * z_dim1], ldz, & + work[ppwo], &i__7, &c_b14, &work[pw], &nh); + i__6 = nnb << 1; + dlacpy_("All", &nh, &i__6, &work[pw], &nh, &z__[topq + + j * z_dim1], ldz); + } + ppwo += (nnb << 2) * nnb; + } + } + } + } + +/* Use unblocked code to reduce the rest of the matrix */ +/* Avoid re-initialization of modified Q and Z. */ + + *(unsigned char *)compq2 = *(unsigned char *)compq; + *(unsigned char *)compz2 = *(unsigned char *)compz; + if (jcol != *ilo) { + if (wantq) { + *(unsigned char *)compq2 = 'V'; + } + if (wantz) { + *(unsigned char *)compz2 = 'V'; + } + } + + if (jcol < *ihi) { + dgghrd_(compq2, compz2, n, &jcol, ihi, &a[a_offset], lda, &b[b_offset] + , ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &ierr); + } + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DGGHD3 */ + +} /* dgghd3_ */ + diff --git a/lapack-netlib/SRC/dgghrd.c b/lapack-netlib/SRC/dgghrd.c new file mode 100644 index 000000000..9cf9363d3 --- /dev/null +++ b/lapack-netlib/SRC/dgghrd.c @@ -0,0 +1,784 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGGHRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGHRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, */ +/* LDQ, Z, LDZ, INFO ) */ + +/* CHARACTER COMPQ, COMPZ */ +/* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGHRD reduces a pair of real matrices (A,B) to generalized upper */ +/* > Hessenberg form using orthogonal transformations, where A is a */ +/* > general matrix and B is upper triangular. The form of the */ +/* > generalized eigenvalue problem is */ +/* > A*x = lambda*B*x, */ +/* > and B is typically made upper triangular by computing its QR */ +/* > factorization and moving the orthogonal matrix Q to the left side */ +/* > of the equation. */ +/* > */ +/* > This subroutine simultaneously reduces A to a Hessenberg matrix H: */ +/* > Q**T*A*Z = H */ +/* > and transforms B to another upper triangular matrix T: */ +/* > Q**T*B*Z = T */ +/* > in order to reduce the problem to its standard form */ +/* > H*y = lambda*T*y */ +/* > where y = Z**T*x. */ +/* > */ +/* > The orthogonal matrices Q and Z are determined as products of Givens */ +/* > rotations. They may either be formed explicitly, or they may be */ +/* > postmultiplied into input matrices Q1 and Z1, so that */ +/* > */ +/* > Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T */ +/* > */ +/* > Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T */ +/* > */ +/* > If Q1 is the orthogonal matrix from the QR factorization of B in the */ +/* > original equation A*x = lambda*B*x, then DGGHRD reduces the original */ +/* > problem to generalized Hessenberg form. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'N': do not compute Q; */ +/* > = 'I': Q is initialized to the unit matrix, and the */ +/* > orthogonal matrix Q is returned; */ +/* > = 'V': Q must contain an orthogonal matrix Q1 on entry, */ +/* > and the product Q1*Q is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': do not compute Z; */ +/* > = 'I': Z is initialized to the unit matrix, and the */ +/* > orthogonal matrix Z is returned; */ +/* > = 'V': Z must contain an orthogonal matrix Z1 on entry, */ +/* > and the product Z1*Z is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > ILO and IHI mark the rows and columns of A which are to be */ +/* > reduced. It is assumed that A is already upper triangular */ +/* > in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */ +/* > normally set by a previous call to DGGBAL; otherwise they */ +/* > should be set to 1 and N respectively. */ +/* > 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the N-by-N general matrix to be reduced. */ +/* > On exit, the upper triangle and the first subdiagonal of A */ +/* > are overwritten with the upper Hessenberg matrix H, and the */ +/* > rest is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the N-by-N upper triangular matrix B. */ +/* > On exit, the upper triangular matrix T = Q**T B Z. The */ +/* > elements below the diagonal are set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */ +/* > On entry, if COMPQ = 'V', the orthogonal matrix Q1, */ +/* > typically from the QR factorization of B. */ +/* > On exit, if COMPQ='I', the orthogonal matrix Q, and if */ +/* > COMPQ = 'V', the product Q1*Q. */ +/* > Not referenced if COMPQ='N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', the orthogonal matrix Z1. */ +/* > On exit, if COMPZ='I', the orthogonal matrix Z, and if */ +/* > COMPZ = 'V', the product Z1*Z. */ +/* > Not referenced if COMPZ='N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. */ +/* > LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine reduces A to Hessenberg and B to triangular form by */ +/* > an unblocked reduction, as described in _Matrix_Computations_, */ +/* > by Golub and Van Loan (Johns Hopkins Press.) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dgghrd_(char *compq, char *compz, integer *n, integer * + ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *q, integer *ldq, doublereal *z__, integer * + ldz, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2, i__3; + + /* Local variables */ + integer jcol; + doublereal temp; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer jrow; + doublereal c__, s; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), xerbla_(char *, integer *, ftnlen); + integer icompq, icompz; + logical ilq, ilz; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode COMPQ */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + if (lsame_(compq, "N")) { + ilq = FALSE_; + icompq = 1; + } else if (lsame_(compq, "V")) { + ilq = TRUE_; + icompq = 2; + } else if (lsame_(compq, "I")) { + ilq = TRUE_; + icompq = 3; + } else { + icompq = 0; + } + +/* Decode COMPZ */ + + if (lsame_(compz, "N")) { + ilz = FALSE_; + icompz = 1; + } else if (lsame_(compz, "V")) { + ilz = TRUE_; + icompz = 2; + } else if (lsame_(compz, "I")) { + ilz = TRUE_; + icompz = 3; + } else { + icompz = 0; + } + +/* Test the input parameters. */ + + *info = 0; + if (icompq <= 0) { + *info = -1; + } else if (icompz <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1) { + *info = -4; + } else if (*ihi > *n || *ihi < *ilo - 1) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (ilq && *ldq < *n || *ldq < 1) { + *info = -11; + } else if (ilz && *ldz < *n || *ldz < 1) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGHRD", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize Q and Z if desired. */ + + if (icompq == 3) { + dlaset_("Full", n, n, &c_b10, &c_b11, &q[q_offset], ldq); + } + if (icompz == 3) { + dlaset_("Full", n, n, &c_b10, &c_b11, &z__[z_offset], ldz); + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Zero out lower triangle of B */ + + i__1 = *n - 1; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = jcol + 1; jrow <= i__2; ++jrow) { + b[jrow + jcol * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + +/* Reduce A and B */ + + i__1 = *ihi - 2; + for (jcol = *ilo; jcol <= i__1; ++jcol) { + + i__2 = jcol + 2; + for (jrow = *ihi; jrow >= i__2; --jrow) { + +/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */ + + temp = a[jrow - 1 + jcol * a_dim1]; + dlartg_(&temp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 + + jcol * a_dim1]); + a[jrow + jcol * a_dim1] = 0.; + i__3 = *n - jcol; + drot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + ( + jcol + 1) * a_dim1], lda, &c__, &s); + i__3 = *n + 2 - jrow; + drot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + ( + jrow - 1) * b_dim1], ldb, &c__, &s); + if (ilq) { + drot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1 + + 1], &c__1, &c__, &s); + } + +/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */ + + temp = b[jrow + jrow * b_dim1]; + dlartg_(&temp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow + + jrow * b_dim1]); + b[jrow + (jrow - 1) * b_dim1] = 0.; + drot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 + + 1], &c__1, &c__, &s); + i__3 = jrow - 1; + drot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1 + + 1], &c__1, &c__, &s); + if (ilz) { + drot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) * + z_dim1 + 1], &c__1, &c__, &s); + } +/* L30: */ + } +/* L40: */ + } + + return 0; + +/* End of DGGHRD */ + +} /* dgghrd_ */ + diff --git a/lapack-netlib/SRC/dgglse.c b/lapack-netlib/SRC/dgglse.c new file mode 100644 index 000000000..e7fc88a34 --- /dev/null +++ b/lapack-netlib/SRC/dgglse.c @@ -0,0 +1,792 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGLSE solves overdetermined or underdetermined systems for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGLSE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LWORK, M, N, P */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ), */ +/* $ WORK( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGLSE solves the linear equality-constrained least squares (LSE) */ +/* > problem: */ +/* > */ +/* > minimize || c - A*x ||_2 subject to B*x = d */ +/* > */ +/* > where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */ +/* > M-vector, and d is a given P-vector. It is assumed that */ +/* > P <= N <= M+P, and */ +/* > */ +/* > rank(B) = P and rank( (A) ) = N. */ +/* > ( (B) ) */ +/* > */ +/* > These conditions ensure that the LSE problem has a unique solution, */ +/* > which is obtained using a generalized RQ factorization of the */ +/* > matrices (B, A) given by */ +/* > */ +/* > B = (0 R)*Q, A = Z*T*Q. */ +/* > \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 matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. 0 <= P <= N <= M+P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the f2cmin(M,N)-by-N upper trapezoidal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */ +/* > contains the P-by-P upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (M) */ +/* > On entry, C contains the right hand side vector for the */ +/* > least squares part of the LSE problem. */ +/* > On exit, the residual sum of squares for the solution */ +/* > is given by the sum of squares of elements N-P+1 to M of */ +/* > vector C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (P) */ +/* > On entry, D contains the right hand side vector for the */ +/* > constrained equation. */ +/* > On exit, D is destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, X is the solution of the LSE problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,M+N+P). */ +/* > For optimum performance LWORK >= P+f2cmin(M,N)+f2cmax(M,N)*NB, */ +/* > where NB is an upper bound for the optimal blocksizes for */ +/* > DGEQRF, SGERQF, DORMQR and SORMRQ. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1: the upper triangular factor R associated with B in the */ +/* > generalized RQ factorization of the pair (B, A) is */ +/* > singular, so that rank(B) < P; the least squares */ +/* > solution could not be computed. */ +/* > = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */ +/* > T associated with A in the generalized RQ factorization */ +/* > of the pair (B, A) is singular, so that */ +/* > rank( (A) ) < N; the least squares solution could not */ +/* > ( (B) ) */ +/* > be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal * + a, integer *lda, doublereal *b, integer *ldb, doublereal *c__, + doublereal *d__, doublereal *x, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer lopt; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *), daxpy_(integer + *, doublereal *, doublereal *, integer *, doublereal *, integer *) + , dtrmv_(char *, char *, char *, integer *, doublereal *, integer + *, doublereal *, integer *); + integer nb, mn, nr; + extern /* Subroutine */ int dggrqf_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer lwkmin, nb1, nb2, nb3, nb4; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), + dormrq_(char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --c__; + --d__; + --x; + --work; + + /* Function Body */ + *info = 0; + mn = f2cmin(*m,*n); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*p < 0 || *p > *n || *p < *n - *m) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldb < f2cmax(1,*p)) { + *info = -7; + } + +/* Calculate workspace */ + + if (*info == 0) { + if (*n == 0) { + lwkmin = 1; + lwkopt = 1; + } else { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2), i__1 = f2cmax(i__1,nb3); + nb = f2cmax(i__1,nb4); + lwkmin = *m + *n + *p; + lwkopt = *p + mn + f2cmax(*m,*n) * nb; + } + work[1] = (doublereal) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGLSE", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Compute the GRQ factorization of matrices B and A: */ + +/* B*Q**T = ( 0 T12 ) P Z**T*A*Q**T = ( R11 R12 ) N-P */ +/* N-P P ( 0 R22 ) M+P-N */ +/* N-P P */ + +/* where T12 and R11 are upper triangular, and Q and Z are */ +/* orthogonal. */ + + i__1 = *lwork - *p - mn; + dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p + + 1], &work[*p + mn + 1], &i__1, info); + lopt = (integer) work[*p + mn + 1]; + +/* Update c = Z**T *c = ( c1 ) N-P */ +/* ( c2 ) M+P-N */ + + i__1 = f2cmax(1,*m); + i__2 = *lwork - *p - mn; + dormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p + + 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*p + mn + 1]; + lopt = f2cmax(i__1,i__2); + +/* Solve T12*x2 = d for x2 */ + + if (*p > 0) { + dtrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p + + 1) * b_dim1 + 1], ldb, &d__[1], p, info); + + if (*info > 0) { + *info = 1; + return 0; + } + +/* Put the solution in X */ + + dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1); + +/* Update c1 */ + + i__1 = *n - *p; + dgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 + + 1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1); + } + +/* Solve R11*x1 = c1 for x1 */ + + if (*n > *p) { + i__1 = *n - *p; + i__2 = *n - *p; + dtrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[ + a_offset], lda, &c__[1], &i__2, info); + + if (*info > 0) { + *info = 2; + return 0; + } + +/* Put the solutions in X */ + + i__1 = *n - *p; + dcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1); + } + +/* Compute the residual vector: */ + + if (*m < *n) { + nr = *m + *p - *n; + if (nr > 0) { + i__1 = *n - *m; + dgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m + + 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n - + *p + 1], &c__1); + } + } else { + nr = *p; + } + if (nr > 0) { + dtrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n + - *p + 1) * a_dim1], lda, &d__[1], &c__1); + daxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1); + } + +/* Backward transformation x = Q**T*x */ + + i__1 = *lwork - *p - mn; + dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[ + 1], n, &work[*p + mn + 1], &i__1, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*p + mn + 1]; + work[1] = (doublereal) (*p + mn + f2cmax(i__1,i__2)); + + return 0; + +/* End of DGGLSE */ + +} /* dgglse_ */ + diff --git a/lapack-netlib/SRC/dggqrf.c b/lapack-netlib/SRC/dggqrf.c new file mode 100644 index 000000000..bbb2e74df --- /dev/null +++ b/lapack-netlib/SRC/dggqrf.c @@ -0,0 +1,718 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGGQRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGQRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, */ +/* LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LWORK, M, N, P */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGQRF computes a generalized QR factorization of an N-by-M matrix A */ +/* > and an N-by-P matrix B: */ +/* > */ +/* > A = Q*R, B = Q*T*Z, */ +/* > */ +/* > where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */ +/* > matrix, and R and T assume one of the forms: */ +/* > */ +/* > if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, */ +/* > ( 0 ) N-M N M-N */ +/* > M */ +/* > */ +/* > where R11 is upper triangular, and */ +/* > */ +/* > if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, */ +/* > P-N N ( T21 ) P */ +/* > P */ +/* > */ +/* > where T12 or T21 is upper triangular. */ +/* > */ +/* > In particular, if B is square and nonsingular, the GQR factorization */ +/* > of A and B implicitly gives the QR factorization of inv(B)*A: */ +/* > */ +/* > inv(B)*A = Z**T*(inv(T)*R) */ +/* > */ +/* > where inv(B) denotes the inverse of the matrix B, and Z**T denotes the */ +/* > transpose of the matrix Z. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of columns of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,M) */ +/* > On entry, the N-by-M matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the f2cmin(N,M)-by-M upper trapezoidal matrix R (R is */ +/* > upper triangular if N >= M); the elements below the diagonal, */ +/* > with the array TAUA, represent the orthogonal matrix Q as a */ +/* > product of f2cmin(N,M) elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUA */ +/* > \verbatim */ +/* > TAUA is DOUBLE PRECISION array, dimension (f2cmin(N,M)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the orthogonal matrix Q (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,P) */ +/* > On entry, the N-by-P matrix B. */ +/* > On exit, if N <= P, the upper triangle of the subarray */ +/* > B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ +/* > if N > P, the elements on and above the (N-P)-th subdiagonal */ +/* > contain the N-by-P upper trapezoidal matrix T; the remaining */ +/* > elements, with the array TAUB, represent the orthogonal */ +/* > matrix Z as a product of elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUB */ +/* > \verbatim */ +/* > TAUB is DOUBLE PRECISION array, dimension (f2cmin(N,P)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the orthogonal matrix Z (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N,M,P). */ +/* > For optimum performance LWORK >= f2cmax(N,M,P)*f2cmax(NB1,NB2,NB3), */ +/* > where NB1 is the optimal blocksize for the QR factorization */ +/* > of an N-by-M matrix, NB2 is the optimal blocksize for the */ +/* > RQ factorization of an N-by-P matrix, and NB3 is the optimal */ +/* > blocksize for a call of DORMQR. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = f2cmin(n,m). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - taua * v * v**T */ +/* > */ +/* > where taua is a real scalar, and v is a real vector with */ +/* > v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ +/* > and taua in TAUA(i). */ +/* > To form Q explicitly, use LAPACK subroutine DORGQR. */ +/* > To use Q to update another matrix, use LAPACK subroutine DORMQR. */ +/* > */ +/* > The matrix Z is represented as a product of elementary reflectors */ +/* > */ +/* > Z = H(1) H(2) . . . H(k), where k = f2cmin(n,p). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - taub * v * v**T */ +/* > */ +/* > where taub is a real scalar, and v is a real vector with */ +/* > v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in */ +/* > B(n-k+i,1:p-k+i-1), and taub in TAUB(i). */ +/* > To form Z explicitly, use LAPACK subroutine DORGRQ. */ +/* > To use Z to update another matrix, use LAPACK subroutine DORMRQ. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggqrf_(integer *n, integer *m, integer *p, doublereal * + a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, + doublereal *taub, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer lopt, nb; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dgerqf_(integer *, integer *, doublereal *, integer *, doublereal + *, doublereal *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer nb1, nb2, nb3; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --taua; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --taub; + --work; + + /* Function Body */ + *info = 0; + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "DGERQF", " ", n, p, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1, (ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); +/* Computing MAX */ + i__1 = f2cmax(*n,*m); + lwkopt = f2cmax(i__1,*p) * nb; + work[1] = (doublereal) lwkopt; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*p < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*n), i__1 = f2cmax(i__1,*m); + if (*lwork < f2cmax(i__1,*p) && ! lquery) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGQRF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* QR factorization of N-by-M matrix A: A = Q*R */ + + dgeqrf_(n, m, &a[a_offset], lda, &taua[1], &work[1], lwork, info); + lopt = (integer) work[1]; + +/* Update B := Q**T*B. */ + + i__1 = f2cmin(*n,*m); + dormqr_("Left", "Transpose", n, p, &i__1, &a[a_offset], lda, &taua[1], &b[ + b_offset], ldb, &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + lopt = f2cmax(i__1,i__2); + +/* RQ factorization of N-by-P matrix B: B = T*Z. */ + + dgerqf_(n, p, &b[b_offset], ldb, &taub[1], &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + work[1] = (doublereal) f2cmax(i__1,i__2); + + return 0; + +/* End of DGGQRF */ + +} /* dggqrf_ */ + diff --git a/lapack-netlib/SRC/dggrqf.c b/lapack-netlib/SRC/dggrqf.c new file mode 100644 index 000000000..44991a0f2 --- /dev/null +++ b/lapack-netlib/SRC/dggrqf.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 DGGRQF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGRQF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, */ +/* LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LWORK, M, N, P */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGRQF computes a generalized RQ factorization of an M-by-N matrix A */ +/* > and a P-by-N matrix B: */ +/* > */ +/* > A = R*Q, B = Z*T*Q, */ +/* > */ +/* > where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */ +/* > matrix, and R and T assume one of the forms: */ +/* > */ +/* > if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */ +/* > N-M M ( R21 ) N */ +/* > N */ +/* > */ +/* > where R12 or R21 is upper triangular, and */ +/* > */ +/* > if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */ +/* > ( 0 ) P-N P N-P */ +/* > N */ +/* > */ +/* > where T11 is upper triangular. */ +/* > */ +/* > In particular, if B is square and nonsingular, the GRQ factorization */ +/* > of A and B implicitly gives the RQ factorization of A*inv(B): */ +/* > */ +/* > A*inv(B) = (R*inv(T))*Z**T */ +/* > */ +/* > where inv(B) denotes the inverse of the matrix B, and Z**T denotes the */ +/* > transpose of the matrix Z. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, if M <= N, the upper triangle of the subarray */ +/* > A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */ +/* > if M > N, the elements on and above the (M-N)-th subdiagonal */ +/* > contain the M-by-N upper trapezoidal matrix R; the remaining */ +/* > elements, with the array TAUA, represent the orthogonal */ +/* > matrix Q as a product of elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUA */ +/* > \verbatim */ +/* > TAUA is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the orthogonal matrix Q (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the f2cmin(P,N)-by-N upper trapezoidal matrix T (T is */ +/* > upper triangular if P >= N); the elements below the diagonal, */ +/* > with the array TAUB, represent the orthogonal matrix Z as a */ +/* > product of elementary reflectors (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUB */ +/* > \verbatim */ +/* > TAUB is DOUBLE PRECISION array, dimension (f2cmin(P,N)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the orthogonal matrix Z (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N,M,P). */ +/* > For optimum performance LWORK >= f2cmax(N,M,P)*f2cmax(NB1,NB2,NB3), */ +/* > where NB1 is the optimal blocksize for the RQ factorization */ +/* > of an M-by-N matrix, NB2 is the optimal blocksize for the */ +/* > QR factorization of a P-by-N matrix, and NB3 is the optimal */ +/* > blocksize for a call of DORMRQ. */ +/* > */ +/* > 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 INF0= -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = f2cmin(m,n). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - taua * v * v**T */ +/* > */ +/* > where taua is a real scalar, and v is a real vector with */ +/* > v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */ +/* > A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */ +/* > To form Q explicitly, use LAPACK subroutine DORGRQ. */ +/* > To use Q to update another matrix, use LAPACK subroutine DORMRQ. */ +/* > */ +/* > The matrix Z is represented as a product of elementary reflectors */ +/* > */ +/* > Z = H(1) H(2) . . . H(k), where k = f2cmin(p,n). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - taub * v * v**T */ +/* > */ +/* > where taub is a real scalar, and v is a real vector with */ +/* > v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */ +/* > and taub in TAUB(i). */ +/* > To form Z explicitly, use LAPACK subroutine DORGQR. */ +/* > To use Z to update another matrix, use LAPACK subroutine DORMQR. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, doublereal * + a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, + doublereal *taub, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer lopt, nb; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dgerqf_(integer *, integer *, doublereal *, integer *, doublereal + *, doublereal *, integer *, integer *), xerbla_(char *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer nb1, nb2, nb3; + extern /* Subroutine */ int dormrq_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --taua; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --taub; + --work; + + /* Function Body */ + *info = 0; + nb1 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "DGEQRF", " ", p, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1, (ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); +/* Computing MAX */ + i__1 = f2cmax(*n,*m); + lwkopt = f2cmax(i__1,*p) * nb; + work[1] = (doublereal) lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*p < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldb < f2cmax(1,*p)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m), i__1 = f2cmax(i__1,*p); + if (*lwork < f2cmax(i__1,*n) && ! lquery) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGRQF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* RQ factorization of M-by-N matrix A: A = R*Q */ + + dgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info); + lopt = (integer) work[1]; + +/* Update B := B*Q**T */ + + i__1 = f2cmin(*m,*n); +/* Computing MAX */ + i__2 = 1, i__3 = *m - *n + 1; + dormrq_("Right", "Transpose", p, n, &i__1, &a[f2cmax(i__2,i__3) + a_dim1], + lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + lopt = f2cmax(i__1,i__2); + +/* QR factorization of P-by-N matrix B: B = Z*T */ + + dgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + work[1] = (doublereal) f2cmax(i__1,i__2); + + return 0; + +/* End of DGGRQF */ + +} /* dggrqf_ */ + diff --git a/lapack-netlib/SRC/dggsvd3.c b/lapack-netlib/SRC/dggsvd3.c new file mode 100644 index 000000000..ae13a3aa2 --- /dev/null +++ b/lapack-netlib/SRC/dggsvd3.c @@ -0,0 +1,938 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGSVD3 computes the singular value decomposition (SVD) for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGSVD3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */ +/* LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */ +/* LWORK, IWORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), Q( LDQ, * ), U( LDU, * ), */ +/* $ V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGSVD3 computes the generalized singular value decomposition (GSVD) */ +/* > of an M-by-N real matrix A and P-by-N real matrix B: */ +/* > */ +/* > U**T*A*Q = D1*( 0 R ), V**T*B*Q = D2*( 0 R ) */ +/* > */ +/* > where U, V and Q are orthogonal matrices. */ +/* > Let K+L = the effective numerical rank of the matrix (A**T,B**T)**T, */ +/* > then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */ +/* > D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */ +/* > following structures, respectively: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) */ +/* > L ( 0 0 R22 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The routine computes C, S, R, and optionally the orthogonal */ +/* > transformation matrices U, V and Q. */ +/* > */ +/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */ +/* > A and B implicitly gives the SVD of A*inv(B): */ +/* > A*inv(B) = U*(D1*inv(D2))*V**T. */ +/* > If ( A**T,B**T)**T has orthonormal columns, then the GSVD of A and B is */ +/* > also equal to the CS decomposition of A and B. Furthermore, the GSVD */ +/* > can be used to derive the solution of the eigenvalue problem: */ +/* > A**T*A x = lambda* B**T*B x. */ +/* > In some literature, the GSVD of A and B is presented in the form */ +/* > U**T*A*X = ( 0 D1 ), V**T*B*X = ( 0 D2 ) */ +/* > where U and V are orthogonal and X is nonsingular, D1 and D2 are */ +/* > ``diagonal''. The former GSVD form can be converted to the latter */ +/* > form by taking the nonsingular matrix X as */ +/* > */ +/* > X = Q*( I 0 ) */ +/* > ( 0 inv(R) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Orthogonal matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Orthogonal matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Orthogonal matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose. */ +/* > K + L = effective numerical rank of (A**T,B**T)**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular matrix R, or part of R. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix R if M-K-L < 0. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = C, */ +/* > BETA(K+1:K+L) = S, */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */ +/* > BETA(K+1:M) =S, BETA(M+1:K+L) =1 */ +/* > and */ +/* > ALPHA(K+L+1:N) = 0 */ +/* > BETA(K+L+1:N) = 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is DOUBLE PRECISION array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > On exit, IWORK stores the sorting information. More */ +/* > precisely, the following loop will sort ALPHA */ +/* > for I = K+1, f2cmin(M,K+L) */ +/* > swap ALPHA(I) and ALPHA(IWORK(I)) */ +/* > endfor */ +/* > such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(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, the Jacobi-type procedure failed to */ +/* > converge. For further details, see subroutine DTGSJA. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLA DOUBLE PRECISION */ +/* > TOLB DOUBLE PRECISION */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > rank of (A**T,B**T)**T. Generally, they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date August 2015 */ + +/* > \ingroup doubleGEsing */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > DGGSVD3 replaces the deprecated subroutine DGGSVD. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggsvd3_(char *jobu, char *jobv, char *jobq, integer *m, + integer *n, integer *p, integer *k, integer *l, doublereal *a, + integer *lda, doublereal *b, integer *ldb, doublereal *alpha, + doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer + *ldv, doublereal *q, integer *ldq, doublereal *work, integer *lwork, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2; + + /* Local variables */ + integer ibnd; + doublereal tola; + integer isub; + doublereal tolb, unfl, temp, smax; + integer ncallmycycle, i__, j; + extern logical lsame_(char *, char *); + doublereal anorm, bnorm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical wantq, wantu, wantv; + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dtgsja_(char *, char *, char *, integer *, + integer *, integer *, integer *, integer *, doublereal *, integer + *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int dggsvp3_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal ulp; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* August 2015 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + --iwork; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + lquery = *lwork == -1; + lwkopt = 1; + +/* Test the input arguments */ + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*p < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } else if (*lwork < 1 && ! lquery) { + *info = -24; + } + +/* Compute workspace */ + + if (*info == 0) { + dggsvp3_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], + ldb, &tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, + &q[q_offset], ldq, &iwork[1], &work[1], &work[1], &c_n1, + info); + lwkopt = *n + (integer) work[1]; +/* Computing MAX */ + i__1 = *n << 1; + lwkopt = f2cmax(i__1,lwkopt); + lwkopt = f2cmax(1,lwkopt); + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGSVD3", &i__1, (ftnlen)7); + return 0; + } + if (lquery) { + return 0; + } + +/* Compute the Frobenius norm of matrices A and B */ + + anorm = dlange_("1", m, n, &a[a_offset], lda, &work[1]); + bnorm = dlange_("1", p, n, &b[b_offset], ldb, &work[1]); + +/* Get machine precision and set up threshold for determining */ +/* the effective numerical rank of the matrices A and B. */ + + ulp = dlamch_("Precision"); + unfl = dlamch_("Safe Minimum"); + tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp; + tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp; + +/* Preprocessing */ + + i__1 = *lwork - *n; + dggsvp3_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, + &tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[ + q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], &i__1, info); + +/* Compute the GSVD of two upper "triangular" matrices */ + + dtgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], + ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ + v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info); + +/* Sort the singular values and store the pivot indices in IWORK */ +/* Copy ALPHA to WORK, then sort ALPHA in WORK */ + + dcopy_(n, &alpha[1], &c__1, &work[1], &c__1); +/* Computing MIN */ + i__1 = *l, i__2 = *m - *k; + ibnd = f2cmin(i__1,i__2); + i__1 = ibnd; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for largest ALPHA(K+I) */ + + isub = i__; + smax = work[*k + i__]; + i__2 = ibnd; + for (j = i__ + 1; j <= i__2; ++j) { + temp = work[*k + j]; + if (temp > smax) { + isub = j; + smax = temp; + } +/* L10: */ + } + if (isub != i__) { + work[*k + isub] = work[*k + i__]; + work[*k + i__] = smax; + iwork[*k + i__] = *k + isub; + } else { + iwork[*k + i__] = *k + i__; + } +/* L20: */ + } + + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DGGSVD3 */ + +} /* dggsvd3_ */ + diff --git a/lapack-netlib/SRC/dggsvp3.c b/lapack-netlib/SRC/dggsvp3.c new file mode 100644 index 000000000..eea0f94a9 --- /dev/null +++ b/lapack-netlib/SRC/dggsvp3.c @@ -0,0 +1,1058 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGGSVP3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGSVP3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, */ +/* TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, */ +/* IWORK, TAU, WORK, LWORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK */ +/* DOUBLE PRECISION TOLA, TOLB */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGGSVP3 computes orthogonal matrices U, V and Q such that */ +/* > */ +/* > N-K-L K L */ +/* > U**T*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > V**T*B*Q = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */ +/* > numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. */ +/* > */ +/* > This decomposition is the preprocessing step for computing the */ +/* > Generalized Singular Value Decomposition (GSVD), see subroutine */ +/* > DGGSVD3. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Orthogonal matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Orthogonal matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Orthogonal matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular (or trapezoidal) matrix */ +/* > described in the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix described in */ +/* > the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is DOUBLE PRECISION */ +/* > */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > numerical rank of matrix B and a subblock of A. Generally, */ +/* > they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose section. */ +/* > K + L = effective numerical rank of (A**T,B**T)**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is DOUBLE PRECISION array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the orthogonal matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the orthogonal matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the orthogonal matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date August 2015 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The subroutine uses LAPACK subroutine DGEQP3 for the QR factorization */ +/* > with column pivoting to detect the effective numerical rank of the */ +/* > a matrix. It may be replaced by a better rank determination strategy. */ +/* > */ +/* > DGGSVP3 replaces the deprecated subroutine DGGSVP. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggsvp3_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer + *l, doublereal *u, integer *ldu, doublereal *v, integer *ldv, + doublereal *q, integer *ldq, integer *iwork, doublereal *tau, + doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + logical wantq, wantu, wantv; + extern /* Subroutine */ int dgeqp3_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, doublereal *, integer *, + integer *), dgeqr2_(integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dgerq2_(integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *), dorg2r_(integer *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), dorm2r_(char * + , char *, integer *, integer *, integer *, doublereal *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *), dormr2_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dlacpy_(char + *, integer *, integer *, doublereal *, integer *, doublereal *, + integer *), dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), dlapmt_(logical *, integer *, + integer *, doublereal *, integer *, integer *); + logical forwrd; + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* August 2015 */ + + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --iwork; + --tau; + --work; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + forwrd = TRUE_; + lquery = *lwork == -1; + lwkopt = 1; + +/* Test the input arguments */ + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -8; + } else if (*ldb < f2cmax(1,*p)) { + *info = -10; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } else if (*lwork < 1 && ! lquery) { + *info = -24; + } + +/* Compute workspace */ + + if (*info == 0) { + dgeqp3_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &c_n1, + info); + lwkopt = (integer) work[1]; + if (wantv) { + lwkopt = f2cmax(lwkopt,*p); + } +/* Computing MAX */ + i__1 = lwkopt, i__2 = f2cmin(*n,*p); + lwkopt = f2cmax(i__1,i__2); + lwkopt = f2cmax(lwkopt,*m); + if (wantq) { + lwkopt = f2cmax(lwkopt,*n); + } + dgeqp3_(m, n, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &c_n1, + info); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + lwkopt = f2cmax(1,lwkopt); + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGSVP3", &i__1, (ftnlen)7); + return 0; + } + if (lquery) { + return 0; + } + +/* QR with column pivoting of B: B*P = V*( S11 S12 ) */ +/* ( 0 0 ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + dgeqp3_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], lwork, + info); + +/* Update A := A*P */ + + dlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); + +/* Determine the effective rank of matrix B. */ + + *l = 0; + i__1 = f2cmin(*p,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) > *tolb) { + ++(*l); + } +/* L20: */ + } + + if (wantv) { + +/* Copy the details of V, and form V. */ + + dlaset_("Full", p, p, &c_b14, &c_b14, &v[v_offset], ldv); + if (*p > 1) { + i__1 = *p - 1; + dlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], + ldv); + } + i__1 = f2cmin(*p,*n); + dorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); + } + +/* Clean up B */ + + i__1 = *l - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + if (*p > *l) { + i__1 = *p - *l; + dlaset_("Full", &i__1, n, &c_b14, &c_b14, &b[*l + 1 + b_dim1], ldb); + } + + if (wantq) { + +/* Set Q = I and Update Q := Q*P */ + + dlaset_("Full", n, n, &c_b14, &c_b24, &q[q_offset], ldq); + dlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); + } + + if (*p >= *l && *n != *l) { + +/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */ + + dgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); + +/* Update A := A*Z**T */ + + dormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[ + a_offset], lda, &work[1], info); + + if (wantq) { + +/* Update Q := Q*Z**T */ + + dormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1], + &q[q_offset], ldq, &work[1], info); + } + +/* Clean up B */ + + i__1 = *n - *l; + dlaset_("Full", l, &i__1, &c_b14, &c_b14, &b[b_offset], ldb); + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + + } + +/* Let N-L L */ +/* A = ( A11 A12 ) M, */ + +/* then the following does the complete QR decomposition of A11: */ + +/* A11 = U*( 0 T12 )*P1**T */ +/* ( 0 0 ) */ + + i__1 = *n - *l; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L70: */ + } + i__1 = *n - *l; + dgeqp3_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], lwork, + info); + +/* Determine the effective rank of A11 */ + + *k = 0; +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) > *tola) { + ++(*k); + } +/* L80: */ + } + +/* Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + dorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[( + *n - *l + 1) * a_dim1 + 1], lda, &work[1], info); + + if (wantu) { + +/* Copy the details of U, and form U */ + + dlaset_("Full", m, m, &c_b14, &c_b14, &u[u_offset], ldu); + if (*m > 1) { + i__1 = *m - 1; + i__2 = *n - *l; + dlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] + , ldu); + } +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + dorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); + } + + if (wantq) { + +/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ + + i__1 = *n - *l; + dlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); + } + +/* Clean up A: set the strictly lower triangular part of */ +/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L90: */ + } +/* L100: */ + } + if (*m > *k) { + i__1 = *m - *k; + i__2 = *n - *l; + dlaset_("Full", &i__1, &i__2, &c_b14, &c_b14, &a[*k + 1 + a_dim1], + lda); + } + + if (*n - *l > *k) { + +/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ + + i__1 = *n - *l; + dgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); + + if (wantq) { + +/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T */ + + i__1 = *n - *l; + dormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, & + tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up A */ + + i__1 = *n - *l - *k; + dlaset_("Full", k, &i__1, &c_b14, &c_b14, &a[a_offset], lda); + i__1 = *n - *l; + for (j = *n - *l - *k + 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L110: */ + } +/* L120: */ + } + + } + + if (*m > *k) { + +/* QR factorization of A( K+1:M,N-L+1:N ) */ + + i__1 = *m - *k; + dgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & + work[1], info); + + if (wantu) { + +/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ + + i__1 = *m - *k; +/* Computing MIN */ + i__3 = *m - *k; + i__2 = f2cmin(i__3,*l); + dorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n + - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + + 1], ldu, &work[1], info); + } + +/* Clean up */ + + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L130: */ + } +/* L140: */ + } + + } + + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DGGSVP3 */ + +} /* dggsvp3_ */ + diff --git a/lapack-netlib/SRC/dgsvj0.c b/lapack-netlib/SRC/dgsvj0.c new file mode 100644 index 000000000..6d9eca8ea --- /dev/null +++ b/lapack-netlib/SRC/dgsvj0.c @@ -0,0 +1,1601 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGSVJ0 pre-processor for the routine dgesvj. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGSVJ0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, */ +/* SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP */ +/* DOUBLE PRECISION EPS, SFMIN, TOL */ +/* CHARACTER*1 JOBV */ +/* DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), */ +/* $ WORK( LWORK ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGSVJ0 is called from DGESVJ as a pre-processor and that is its main */ +/* > purpose. It applies Jacobi rotations in the same way as DGESVJ does, but */ +/* > it does not check convergence (stopping criterion). Few tuning */ +/* > parameters (marked by [TP]) are available for the implementer. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > Specifies whether the output from this procedure is used */ +/* > to compute the matrix V: */ +/* > = 'V': the product of the Jacobi rotations is accumulated */ +/* > by postmulyiplying the N-by-N array V. */ +/* > (See the description of V.) */ +/* > = 'A': the product of the Jacobi rotations is accumulated */ +/* > by postmulyiplying the MV-by-N array V. */ +/* > (See the descriptions of MV and V.) */ +/* > = 'N': the Jacobi rotations are not accumulated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the input matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the input matrix A. */ +/* > M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, M-by-N matrix A, such that A*diag(D) represents */ +/* > the input matrix. */ +/* > On exit, */ +/* > A_onexit * D_onexit represents the input matrix A*diag(D) */ +/* > post-multiplied by a sequence of Jacobi rotations, where the */ +/* > rotation threshold and the total number of sweeps are given in */ +/* > TOL and NSWEEP, respectively. */ +/* > (See the descriptions of D, TOL and NSWEEP.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The array D accumulates the scaling factors from the fast scaled */ +/* > Jacobi rotations. */ +/* > On entry, A*diag(D) represents the input matrix. */ +/* > On exit, A_onexit*diag(D_onexit) represents the input matrix */ +/* > post-multiplied by a sequence of Jacobi rotations, where the */ +/* > rotation threshold and the total number of sweeps are given in */ +/* > TOL and NSWEEP, respectively. */ +/* > (See the descriptions of A, TOL and NSWEEP.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SVA */ +/* > \verbatim */ +/* > SVA is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, SVA contains the Euclidean norms of the columns of */ +/* > the matrix A*diag(D). */ +/* > On exit, SVA contains the Euclidean norms of the columns of */ +/* > the matrix onexit*diag(D_onexit). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MV */ +/* > \verbatim */ +/* > MV is INTEGER */ +/* > If JOBV = 'A', then MV rows of V are post-multipled by a */ +/* > sequence of Jacobi rotations. */ +/* > If JOBV = 'N', then MV is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,N) */ +/* > If JOBV = 'V' then N rows of V are post-multipled by a */ +/* > sequence of Jacobi rotations. */ +/* > If JOBV = 'A' then MV rows of V are post-multipled by a */ +/* > sequence of Jacobi rotations. */ +/* > If JOBV = 'N', then V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V, LDV >= 1. */ +/* > If JOBV = 'V', LDV >= N. */ +/* > If JOBV = 'A', LDV >= MV. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EPS */ +/* > \verbatim */ +/* > EPS is DOUBLE PRECISION */ +/* > EPS = DLAMCH('Epsilon') */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SFMIN */ +/* > \verbatim */ +/* > SFMIN is DOUBLE PRECISION */ +/* > SFMIN = DLAMCH('Safe Minimum') */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOL */ +/* > \verbatim */ +/* > TOL is DOUBLE PRECISION */ +/* > TOL is the threshold for Jacobi rotations. For a pair */ +/* > A(:,p), A(:,q) of pivot columns, the Jacobi rotation is */ +/* > applied only if DABS(COS(angle(A(:,p),A(:,q)))) > TOL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NSWEEP */ +/* > \verbatim */ +/* > NSWEEP is INTEGER */ +/* > NSWEEP is the number of sweeps of Jacobi rotations to be */ +/* > performed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > LWORK is the dimension of WORK. LWORK >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, then the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > DGSVJ0 is used just to enable DGESVJ to call a simplified version of */ +/* > itself to work on a submatrix of the original matrix. */ +/* > */ +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */ +/* > */ +/* > \par Bugs, Examples and Comments: */ +/* ================================= */ +/* > */ +/* > Please report all bugs and send interesting test examples and comments to */ +/* > drmac@math.hr. Thank you. */ + +/* ===================================================================== */ +/* Subroutine */ int dgsvj0_(char *jobv, integer *m, integer *n, doublereal * + a, integer *lda, doublereal *d__, doublereal *sva, integer *mv, + doublereal *v, integer *ldv, doublereal *eps, doublereal *sfmin, + doublereal *tol, integer *nsweep, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + doublereal d__1, d__2; + + /* Local variables */ + doublereal aapp, aapq, aaqq; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + integer ierr; + doublereal bigtheta; + integer pskipped; + doublereal aapp0; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + doublereal temp1; + integer i__, p, q; + doublereal t, apoaq, aqoap; + extern logical lsame_(char *, char *); + doublereal theta, small; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal fastr[5]; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical applv, rsvec; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), drotm_(integer *, doublereal + *, integer *, doublereal *, integer *, doublereal *); + logical rotok; + doublereal rootsfmin, cs, sn; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer ijblsk, swband, blskip; + doublereal mxaapq; + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal thsign, mxsinj; + integer ir1, emptsw, notrot, iswrot, jbc; + doublereal big; + integer kbl, lkahead, igl, ibr, jgl, nbl, mvl; + doublereal rootbig, rooteps; + integer rowskip; + doublereal roottol; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --sva; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + --work; + + /* Function Body */ + applv = lsame_(jobv, "A"); + rsvec = lsame_(jobv, "V"); + if (! (rsvec || applv || lsame_(jobv, "N"))) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0 || *n > *m) { + *info = -3; + } else if (*lda < *m) { + *info = -5; + } else if ((rsvec || applv) && *mv < 0) { + *info = -8; + } else if (rsvec && *ldv < *n || applv && *ldv < *mv) { + *info = -10; + } else if (*tol <= *eps) { + *info = -13; + } else if (*nsweep < 0) { + *info = -14; + } else if (*lwork < *m) { + *info = -16; + } else { + *info = 0; + } + +/* #:( */ + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGSVJ0", &i__1, (ftnlen)6); + return 0; + } + + if (rsvec) { + mvl = *n; + } else if (applv) { + mvl = *mv; + } + rsvec = rsvec || applv; + rooteps = sqrt(*eps); + rootsfmin = sqrt(*sfmin); + small = *sfmin / *eps; + big = 1. / *sfmin; + rootbig = 1. / rootsfmin; + bigtheta = 1. / rooteps; + roottol = sqrt(*tol); + +/* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- */ + + emptsw = *n * (*n - 1) / 2; + notrot = 0; + fastr[0] = 0.; + +/* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- */ + + swband = 0; +/* [TP] SWBAND is a tuning parameter. It is meaningful and effective */ +/* if SGESVJ is used as a computational routine in the preconditioned */ +/* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure */ +/* ...... */ + kbl = f2cmin(8,*n); +/* [TP] KBL is a tuning parameter that defines the tile size in the */ +/* tiling of the p-q loops of pivot pairs. In general, an optimal */ +/* value of KBL depends on the matrix dimensions and on the */ +/* parameters of the computer's memory. */ + + nbl = *n / kbl; + if (nbl * kbl != *n) { + ++nbl; + } +/* Computing 2nd power */ + i__1 = kbl; + blskip = i__1 * i__1 + 1; +/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */ + rowskip = f2cmin(5,kbl); +/* [TP] ROWSKIP is a tuning parameter. */ + lkahead = 1; +/* [TP] LKAHEAD is a tuning parameter. */ + swband = 0; + pskipped = 0; + + i__1 = *nsweep; + for (i__ = 1; i__ <= i__1; ++i__) { + + mxaapq = 0.; + mxsinj = 0.; + iswrot = 0; + + notrot = 0; + pskipped = 0; + + i__2 = nbl; + for (ibr = 1; ibr <= i__2; ++ibr) { + igl = (ibr - 1) * kbl + 1; + +/* Computing MIN */ + i__4 = lkahead, i__5 = nbl - ibr; + i__3 = f2cmin(i__4,i__5); + for (ir1 = 0; ir1 <= i__3; ++ir1) { + + igl += ir1 * kbl; + +/* Computing MIN */ + i__5 = igl + kbl - 1, i__6 = *n - 1; + i__4 = f2cmin(i__5,i__6); + for (p = igl; p <= i__4; ++p) { + i__5 = *n - p + 1; + q = idamax_(&i__5, &sva[p], &c__1) + p - 1; + if (p != q) { + dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + + 1], &c__1); + if (rsvec) { + dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * + v_dim1 + 1], &c__1); + } + temp1 = sva[p]; + sva[p] = sva[q]; + sva[q] = temp1; + temp1 = d__[p]; + d__[p] = d__[q]; + d__[q] = temp1; + } + + if (ir1 == 0) { + +/* Column norms are periodically updated by explicit */ +/* norm computation. */ +/* Caveat: */ +/* Some BLAS implementations compute DNRM2(M,A(1,p),1) */ +/* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in */ +/* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and */ +/* undeflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). */ +/* Hence, DNRM2 cannot be trusted, not even in the case when */ +/* the true norm is far from the under(over)flow boundaries. */ +/* If properly implemented DNRM2 is available, the IF-THEN-ELSE */ +/* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)". */ + + if (sva[p] < rootbig && sva[p] > rootsfmin) { + sva[p] = dnrm2_(m, &a[p * a_dim1 + 1], &c__1) * + d__[p]; + } else { + temp1 = 0.; + aapp = 1.; + dlassq_(m, &a[p * a_dim1 + 1], &c__1, &temp1, & + aapp); + sva[p] = temp1 * sqrt(aapp) * d__[p]; + } + aapp = sva[p]; + } else { + aapp = sva[p]; + } + + if (aapp > 0.) { + + pskipped = 0; + +/* Computing MIN */ + i__6 = igl + kbl - 1; + i__5 = f2cmin(i__6,*n); + for (q = p + 1; q <= i__5; ++q) { + + aaqq = sva[q]; + if (aaqq > 0.) { + + aapp0 = aapp; + if (aaqq >= 1.) { + rotok = small * aapp <= aaqq; + if (aapp < big / aaqq) { + aapq = ddot_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], & + c__1) * d__[p] * d__[q] / + aaqq / aapp; + } else { + dcopy_(m, &a[p * a_dim1 + 1], &c__1, & + work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aapp, & + d__[p], m, &c__1, &work[1], + lda, &ierr); + aapq = ddot_(m, &work[1], &c__1, &a[q + * a_dim1 + 1], &c__1) * d__[q] + / aaqq; + } + } else { + rotok = aapp <= aaqq / small; + if (aapp > small / aaqq) { + aapq = ddot_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], & + c__1) * d__[p] * d__[q] / + aaqq / aapp; + } else { + dcopy_(m, &a[q * a_dim1 + 1], &c__1, & + work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aaqq, & + d__[q], m, &c__1, &work[1], + lda, &ierr); + aapq = ddot_(m, &work[1], &c__1, &a[p + * a_dim1 + 1], &c__1) * d__[p] + / aapp; + } + } + +/* Computing MAX */ + d__1 = mxaapq, d__2 = abs(aapq); + mxaapq = f2cmax(d__1,d__2); + +/* TO rotate or NOT to rotate, THAT is the question ... */ + + if (abs(aapq) > *tol) { + +/* ROTATED = ROTATED + ONE */ + + if (ir1 == 0) { + notrot = 0; + pskipped = 0; + ++iswrot; + } + + if (rotok) { + + aqoap = aaqq / aapp; + apoaq = aapp / aaqq; + theta = (d__1 = aqoap - apoaq, abs( + d__1)) * -.5 / aapq; + + if (abs(theta) > bigtheta) { + + t = .5 / theta; + fastr[2] = t * d__[p] / d__[q]; + fastr[3] = -t * d__[q] / d__[p]; + drotm_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], + &c__1, fastr); + if (rsvec) { + drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * + v_dim1 + 1], &c__1, fastr); + } +/* Computing MAX */ + d__1 = 0., d__2 = t * apoaq * + aapq + 1.; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - t * aqoap * + aapq; + aapp *= sqrt((f2cmax(d__1,d__2))); +/* Computing MAX */ + d__1 = mxsinj, d__2 = abs(t); + mxsinj = f2cmax(d__1,d__2); + + } else { + + + thsign = -d_sign(&c_b42, &aapq); + t = 1. / (theta + thsign * sqrt( + theta * theta + 1.)); + cs = sqrt(1. / (t * t + 1.)); + sn = t * cs; + +/* Computing MAX */ + d__1 = mxsinj, d__2 = abs(sn); + mxsinj = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = 0., d__2 = t * apoaq * + aapq + 1.; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - t * aqoap * + aapq; + aapp *= sqrt((f2cmax(d__1,d__2))); + + apoaq = d__[p] / d__[q]; + aqoap = d__[q] / d__[p]; + if (d__[p] >= 1.) { + if (d__[q] >= 1.) { + fastr[2] = t * apoaq; + fastr[3] = -t * aqoap; + d__[p] *= cs; + d__[q] *= cs; + drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q * + a_dim1 + 1], &c__1, fastr); + if (rsvec) { + drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[ + q * v_dim1 + 1], &c__1, fastr); + } + } else { + d__1 = -t * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[ + p * a_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[ + q * a_dim1 + 1], &c__1); + d__[p] *= cs; + d__[q] /= cs; + if (rsvec) { + d__1 = -t * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], & + c__1, &v[p * v_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], & + c__1, &v[q * v_dim1 + 1], &c__1); + } + } + } else { + if (d__[q] >= 1.) { + d__1 = t * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[ + q * a_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[ + p * a_dim1 + 1], &c__1); + d__[p] /= cs; + d__[q] *= cs; + if (rsvec) { + d__1 = t * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], & + c__1, &v[q * v_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], & + c__1, &v[p * v_dim1 + 1], &c__1); + } + } else { + if (d__[p] >= d__[q]) { + d__1 = -t * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, + &a[p * a_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, + &a[q * a_dim1 + 1], &c__1); + d__[p] *= cs; + d__[q] /= cs; + if (rsvec) { + d__1 = -t * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], + &c__1, &v[p * v_dim1 + 1], & + c__1); + d__1 = cs * sn * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], + &c__1, &v[q * v_dim1 + 1], & + c__1); + } + } else { + d__1 = t * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, + &a[q * a_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, + &a[p * a_dim1 + 1], &c__1); + d__[p] /= cs; + d__[q] *= cs; + if (rsvec) { + d__1 = t * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], + &c__1, &v[q * v_dim1 + 1], & + c__1); + d__1 = -cs * sn * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], + &c__1, &v[p * v_dim1 + 1], & + c__1); + } + } + } + } + } + + } else { + dcopy_(m, &a[p * a_dim1 + 1], &c__1, & + work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aapp, & + c_b42, m, &c__1, &work[1], + lda, &ierr); + dlascl_("G", &c__0, &c__0, &aaqq, & + c_b42, m, &c__1, &a[q * + a_dim1 + 1], lda, &ierr); + temp1 = -aapq * d__[p] / d__[q]; + daxpy_(m, &temp1, &work[1], &c__1, &a[ + q * a_dim1 + 1], &c__1); + dlascl_("G", &c__0, &c__0, &c_b42, & + aaqq, m, &c__1, &a[q * a_dim1 + + 1], lda, &ierr); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - aapq * aapq; + sva[q] = aaqq * sqrt((f2cmax(d__1,d__2))) + ; + mxsinj = f2cmax(mxsinj,*sfmin); + } +/* END IF ROTOK THEN ... ELSE */ + +/* In the case of cancellation in updating SVA(q), SVA(p) */ +/* recompute SVA(q), SVA(p). */ +/* Computing 2nd power */ + d__1 = sva[q] / aaqq; + if (d__1 * d__1 <= rooteps) { + if (aaqq < rootbig && aaqq > + rootsfmin) { + sva[q] = dnrm2_(m, &a[q * a_dim1 + + 1], &c__1) * d__[q]; + } else { + t = 0.; + aaqq = 1.; + dlassq_(m, &a[q * a_dim1 + 1], & + c__1, &t, &aaqq); + sva[q] = t * sqrt(aaqq) * d__[q]; + } + } + if (aapp / aapp0 <= rooteps) { + if (aapp < rootbig && aapp > + rootsfmin) { + aapp = dnrm2_(m, &a[p * a_dim1 + + 1], &c__1) * d__[p]; + } else { + t = 0.; + aapp = 1.; + dlassq_(m, &a[p * a_dim1 + 1], & + c__1, &t, &aapp); + aapp = t * sqrt(aapp) * d__[p]; + } + sva[p] = aapp; + } + + } else { +/* A(:,p) and A(:,q) already numerically orthogonal */ + if (ir1 == 0) { + ++notrot; + } + ++pskipped; + } + } else { +/* A(:,q) is zero column */ + if (ir1 == 0) { + ++notrot; + } + ++pskipped; + } + + if (i__ <= swband && pskipped > rowskip) { + if (ir1 == 0) { + aapp = -aapp; + } + notrot = 0; + goto L2103; + } + +/* L2002: */ + } +/* END q-LOOP */ + +L2103: +/* bailed out of q-loop */ + sva[p] = aapp; + } else { + sva[p] = aapp; + if (ir1 == 0 && aapp == 0.) { +/* Computing MIN */ + i__5 = igl + kbl - 1; + notrot = notrot + f2cmin(i__5,*n) - p; + } + } + +/* L2001: */ + } +/* end of the p-loop */ +/* end of doing the block ( ibr, ibr ) */ +/* L1002: */ + } +/* end of ir1-loop */ + +/* ........................................................ */ +/* ... go to the off diagonal blocks */ + + igl = (ibr - 1) * kbl + 1; + + i__3 = nbl; + for (jbc = ibr + 1; jbc <= i__3; ++jbc) { + + jgl = (jbc - 1) * kbl + 1; + +/* doing the block at ( ibr, jbc ) */ + + ijblsk = 0; +/* Computing MIN */ + i__5 = igl + kbl - 1; + i__4 = f2cmin(i__5,*n); + for (p = igl; p <= i__4; ++p) { + + aapp = sva[p]; + + if (aapp > 0.) { + + pskipped = 0; + +/* Computing MIN */ + i__6 = jgl + kbl - 1; + i__5 = f2cmin(i__6,*n); + for (q = jgl; q <= i__5; ++q) { + + aaqq = sva[q]; + + if (aaqq > 0.) { + aapp0 = aapp; + +/* -#- M x 2 Jacobi SVD -#- */ + +/* -#- Safe Gram matrix computation -#- */ + + if (aaqq >= 1.) { + if (aapp >= aaqq) { + rotok = small * aapp <= aaqq; + } else { + rotok = small * aaqq <= aapp; + } + if (aapp < big / aaqq) { + aapq = ddot_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], & + c__1) * d__[p] * d__[q] / + aaqq / aapp; + } else { + dcopy_(m, &a[p * a_dim1 + 1], &c__1, & + work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aapp, & + d__[p], m, &c__1, &work[1], + lda, &ierr); + aapq = ddot_(m, &work[1], &c__1, &a[q + * a_dim1 + 1], &c__1) * d__[q] + / aaqq; + } + } else { + if (aapp >= aaqq) { + rotok = aapp <= aaqq / small; + } else { + rotok = aaqq <= aapp / small; + } + if (aapp > small / aaqq) { + aapq = ddot_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], & + c__1) * d__[p] * d__[q] / + aaqq / aapp; + } else { + dcopy_(m, &a[q * a_dim1 + 1], &c__1, & + work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aaqq, & + d__[q], m, &c__1, &work[1], + lda, &ierr); + aapq = ddot_(m, &work[1], &c__1, &a[p + * a_dim1 + 1], &c__1) * d__[p] + / aapp; + } + } + +/* Computing MAX */ + d__1 = mxaapq, d__2 = abs(aapq); + mxaapq = f2cmax(d__1,d__2); + +/* TO rotate or NOT to rotate, THAT is the question ... */ + + if (abs(aapq) > *tol) { + notrot = 0; +/* ROTATED = ROTATED + 1 */ + pskipped = 0; + ++iswrot; + + if (rotok) { + + aqoap = aaqq / aapp; + apoaq = aapp / aaqq; + theta = (d__1 = aqoap - apoaq, abs( + d__1)) * -.5 / aapq; + if (aaqq > aapp0) { + theta = -theta; + } + + if (abs(theta) > bigtheta) { + t = .5 / theta; + fastr[2] = t * d__[p] / d__[q]; + fastr[3] = -t * d__[q] / d__[p]; + drotm_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], + &c__1, fastr); + if (rsvec) { + drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * + v_dim1 + 1], &c__1, fastr); + } +/* Computing MAX */ + d__1 = 0., d__2 = t * apoaq * + aapq + 1.; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - t * aqoap * + aapq; + aapp *= sqrt((f2cmax(d__1,d__2))); +/* Computing MAX */ + d__1 = mxsinj, d__2 = abs(t); + mxsinj = f2cmax(d__1,d__2); + } else { + + + thsign = -d_sign(&c_b42, &aapq); + if (aaqq > aapp0) { + thsign = -thsign; + } + t = 1. / (theta + thsign * sqrt( + theta * theta + 1.)); + cs = sqrt(1. / (t * t + 1.)); + sn = t * cs; +/* Computing MAX */ + d__1 = mxsinj, d__2 = abs(sn); + mxsinj = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = 0., d__2 = t * apoaq * + aapq + 1.; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - t * aqoap * + aapq; + aapp *= sqrt((f2cmax(d__1,d__2))); + + apoaq = d__[p] / d__[q]; + aqoap = d__[q] / d__[p]; + if (d__[p] >= 1.) { + + if (d__[q] >= 1.) { + fastr[2] = t * apoaq; + fastr[3] = -t * aqoap; + d__[p] *= cs; + d__[q] *= cs; + drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q * + a_dim1 + 1], &c__1, fastr); + if (rsvec) { + drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[ + q * v_dim1 + 1], &c__1, fastr); + } + } else { + d__1 = -t * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[ + p * a_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[ + q * a_dim1 + 1], &c__1); + if (rsvec) { + d__1 = -t * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], & + c__1, &v[p * v_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], & + c__1, &v[q * v_dim1 + 1], &c__1); + } + d__[p] *= cs; + d__[q] /= cs; + } + } else { + if (d__[q] >= 1.) { + d__1 = t * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[ + q * a_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[ + p * a_dim1 + 1], &c__1); + if (rsvec) { + d__1 = t * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], & + c__1, &v[q * v_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], & + c__1, &v[p * v_dim1 + 1], &c__1); + } + d__[p] /= cs; + d__[q] *= cs; + } else { + if (d__[p] >= d__[q]) { + d__1 = -t * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, + &a[p * a_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, + &a[q * a_dim1 + 1], &c__1); + d__[p] *= cs; + d__[q] /= cs; + if (rsvec) { + d__1 = -t * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], + &c__1, &v[p * v_dim1 + 1], & + c__1); + d__1 = cs * sn * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], + &c__1, &v[q * v_dim1 + 1], & + c__1); + } + } else { + d__1 = t * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, + &a[q * a_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, + &a[p * a_dim1 + 1], &c__1); + d__[p] /= cs; + d__[q] *= cs; + if (rsvec) { + d__1 = t * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], + &c__1, &v[q * v_dim1 + 1], & + c__1); + d__1 = -cs * sn * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], + &c__1, &v[p * v_dim1 + 1], & + c__1); + } + } + } + } + } + + } else { + if (aapp > aaqq) { + dcopy_(m, &a[p * a_dim1 + 1], & + c__1, &work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aapp, + &c_b42, m, &c__1, &work[1] + , lda, &ierr); + dlascl_("G", &c__0, &c__0, &aaqq, + &c_b42, m, &c__1, &a[q * + a_dim1 + 1], lda, &ierr); + temp1 = -aapq * d__[p] / d__[q]; + daxpy_(m, &temp1, &work[1], &c__1, + &a[q * a_dim1 + 1], & + c__1); + dlascl_("G", &c__0, &c__0, &c_b42, + &aaqq, m, &c__1, &a[q * + a_dim1 + 1], lda, &ierr); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - aapq * + aapq; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); + mxsinj = f2cmax(mxsinj,*sfmin); + } else { + dcopy_(m, &a[q * a_dim1 + 1], & + c__1, &work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aaqq, + &c_b42, m, &c__1, &work[1] + , lda, &ierr); + dlascl_("G", &c__0, &c__0, &aapp, + &c_b42, m, &c__1, &a[p * + a_dim1 + 1], lda, &ierr); + temp1 = -aapq * d__[q] / d__[p]; + daxpy_(m, &temp1, &work[1], &c__1, + &a[p * a_dim1 + 1], & + c__1); + dlascl_("G", &c__0, &c__0, &c_b42, + &aapp, m, &c__1, &a[p * + a_dim1 + 1], lda, &ierr); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - aapq * + aapq; + sva[p] = aapp * sqrt((f2cmax(d__1, + d__2))); + mxsinj = f2cmax(mxsinj,*sfmin); + } + } +/* END IF ROTOK THEN ... ELSE */ + +/* In the case of cancellation in updating SVA(q) */ +/* Computing 2nd power */ + d__1 = sva[q] / aaqq; + if (d__1 * d__1 <= rooteps) { + if (aaqq < rootbig && aaqq > + rootsfmin) { + sva[q] = dnrm2_(m, &a[q * a_dim1 + + 1], &c__1) * d__[q]; + } else { + t = 0.; + aaqq = 1.; + dlassq_(m, &a[q * a_dim1 + 1], & + c__1, &t, &aaqq); + sva[q] = t * sqrt(aaqq) * d__[q]; + } + } +/* Computing 2nd power */ + d__1 = aapp / aapp0; + if (d__1 * d__1 <= rooteps) { + if (aapp < rootbig && aapp > + rootsfmin) { + aapp = dnrm2_(m, &a[p * a_dim1 + + 1], &c__1) * d__[p]; + } else { + t = 0.; + aapp = 1.; + dlassq_(m, &a[p * a_dim1 + 1], & + c__1, &t, &aapp); + aapp = t * sqrt(aapp) * d__[p]; + } + sva[p] = aapp; + } +/* end of OK rotation */ + } else { + ++notrot; + ++pskipped; + ++ijblsk; + } + } else { + ++notrot; + ++pskipped; + ++ijblsk; + } + + if (i__ <= swband && ijblsk >= blskip) { + sva[p] = aapp; + notrot = 0; + goto L2011; + } + if (i__ <= swband && pskipped > rowskip) { + aapp = -aapp; + notrot = 0; + goto L2203; + } + +/* L2200: */ + } +/* end of the q-loop */ +L2203: + + sva[p] = aapp; + + } else { + if (aapp == 0.) { +/* Computing MIN */ + i__5 = jgl + kbl - 1; + notrot = notrot + f2cmin(i__5,*n) - jgl + 1; + } + if (aapp < 0.) { + notrot = 0; + } + } +/* L2100: */ + } +/* end of the p-loop */ +/* L2010: */ + } +/* end of the jbc-loop */ +L2011: +/* 2011 bailed out of the jbc-loop */ +/* Computing MIN */ + i__4 = igl + kbl - 1; + i__3 = f2cmin(i__4,*n); + for (p = igl; p <= i__3; ++p) { + sva[p] = (d__1 = sva[p], abs(d__1)); +/* L2012: */ + } + +/* L2000: */ + } +/* 2000 :: end of the ibr-loop */ + + if (sva[*n] < rootbig && sva[*n] > rootsfmin) { + sva[*n] = dnrm2_(m, &a[*n * a_dim1 + 1], &c__1) * d__[*n]; + } else { + t = 0.; + aapp = 1.; + dlassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp); + sva[*n] = t * sqrt(aapp) * d__[*n]; + } + +/* Additional steering devices */ + + if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) { + swband = i__; + } + + if (i__ > swband + 1 && mxaapq < (doublereal) (*n) * *tol && ( + doublereal) (*n) * mxaapq * mxsinj < *tol) { + goto L1994; + } + + if (notrot >= emptsw) { + goto L1994; + } +/* L1993: */ + } +/* end i=1:NSWEEP loop */ +/* #:) Reaching this point means that the procedure has completed the given */ +/* number of iterations. */ + *info = *nsweep - 1; + goto L1995; +L1994: +/* #:) Reaching this point means that during the i-th sweep all pivots were */ +/* below the given tolerance, causing early exit. */ + + *info = 0; +/* #:) INFO = 0 confirms successful iterations. */ +L1995: + +/* Sort the vector D. */ + i__1 = *n - 1; + for (p = 1; p <= i__1; ++p) { + i__2 = *n - p + 1; + q = idamax_(&i__2, &sva[p], &c__1) + p - 1; + if (p != q) { + temp1 = sva[p]; + sva[p] = sva[q]; + sva[q] = temp1; + temp1 = d__[p]; + d__[p] = d__[q]; + d__[q] = temp1; + dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1); + if (rsvec) { + dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], & + c__1); + } + } +/* L5991: */ + } + + return 0; +} /* dgsvj0_ */ + diff --git a/lapack-netlib/SRC/dgsvj1.c b/lapack-netlib/SRC/dgsvj1.c new file mode 100644 index 000000000..0804adb09 --- /dev/null +++ b/lapack-netlib/SRC/dgsvj1.c @@ -0,0 +1,1239 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGSVJ1 pre-processor for the routine dgesvj, applies Jacobi rotations targeting only particular + pivots. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGSVJ1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, */ +/* EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) */ + +/* DOUBLE PRECISION EPS, SFMIN, TOL */ +/* INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP */ +/* CHARACTER*1 JOBV */ +/* DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), */ +/* $ WORK( LWORK ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGSVJ1 is called from DGESVJ as a pre-processor and that is its main */ +/* > purpose. It applies Jacobi rotations in the same way as DGESVJ does, but */ +/* > it targets only particular pivots and it does not check convergence */ +/* > (stopping criterion). Few tunning parameters (marked by [TP]) are */ +/* > available for the implementer. */ +/* > */ +/* > Further Details */ +/* > ~~~~~~~~~~~~~~~ */ +/* > DGSVJ1 applies few sweeps of Jacobi rotations in the column space of */ +/* > the input M-by-N matrix A. The pivot pairs are taken from the (1,2) */ +/* > off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The */ +/* > block-entries (tiles) of the (1,2) off-diagonal block are marked by the */ +/* > [x]'s in the following scheme: */ +/* > */ +/* > | * * * [x] [x] [x]| */ +/* > | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. */ +/* > | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. */ +/* > |[x] [x] [x] * * * | */ +/* > |[x] [x] [x] * * * | */ +/* > |[x] [x] [x] * * * | */ +/* > */ +/* > In terms of the columns of A, the first N1 columns are rotated 'against' */ +/* > the remaining N-N1 columns, trying to increase the angle between the */ +/* > corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is */ +/* > tiled using quadratic tiles of side KBL. Here, KBL is a tunning parameter. */ +/* > The number of sweeps is given in NSWEEP and the orthogonality threshold */ +/* > is given in TOL. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > Specifies whether the output from this procedure is used */ +/* > to compute the matrix V: */ +/* > = 'V': the product of the Jacobi rotations is accumulated */ +/* > by postmulyiplying the N-by-N array V. */ +/* > (See the description of V.) */ +/* > = 'A': the product of the Jacobi rotations is accumulated */ +/* > by postmulyiplying the MV-by-N array V. */ +/* > (See the descriptions of MV and V.) */ +/* > = 'N': the Jacobi rotations are not accumulated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the input matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the input matrix A. */ +/* > M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > N1 specifies the 2 x 2 block partition, the first N1 columns are */ +/* > rotated 'against' the remaining N-N1 columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, M-by-N matrix A, such that A*diag(D) represents */ +/* > the input matrix. */ +/* > On exit, */ +/* > A_onexit * D_onexit represents the input matrix A*diag(D) */ +/* > post-multiplied by a sequence of Jacobi rotations, where the */ +/* > rotation threshold and the total number of sweeps are given in */ +/* > TOL and NSWEEP, respectively. */ +/* > (See the descriptions of N1, D, TOL and NSWEEP.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The array D accumulates the scaling factors from the fast scaled */ +/* > Jacobi rotations. */ +/* > On entry, A*diag(D) represents the input matrix. */ +/* > On exit, A_onexit*diag(D_onexit) represents the input matrix */ +/* > post-multiplied by a sequence of Jacobi rotations, where the */ +/* > rotation threshold and the total number of sweeps are given in */ +/* > TOL and NSWEEP, respectively. */ +/* > (See the descriptions of N1, A, TOL and NSWEEP.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SVA */ +/* > \verbatim */ +/* > SVA is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, SVA contains the Euclidean norms of the columns of */ +/* > the matrix A*diag(D). */ +/* > On exit, SVA contains the Euclidean norms of the columns of */ +/* > the matrix onexit*diag(D_onexit). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MV */ +/* > \verbatim */ +/* > MV is INTEGER */ +/* > If JOBV = 'A', then MV rows of V are post-multipled by a */ +/* > sequence of Jacobi rotations. */ +/* > If JOBV = 'N', then MV is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,N) */ +/* > If JOBV = 'V', then N rows of V are post-multipled by a */ +/* > sequence of Jacobi rotations. */ +/* > If JOBV = 'A', then MV rows of V are post-multipled by a */ +/* > sequence of Jacobi rotations. */ +/* > If JOBV = 'N', then V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V, LDV >= 1. */ +/* > If JOBV = 'V', LDV >= N. */ +/* > If JOBV = 'A', LDV >= MV. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EPS */ +/* > \verbatim */ +/* > EPS is DOUBLE PRECISION */ +/* > EPS = DLAMCH('Epsilon') */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SFMIN */ +/* > \verbatim */ +/* > SFMIN is DOUBLE PRECISION */ +/* > SFMIN = DLAMCH('Safe Minimum') */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOL */ +/* > \verbatim */ +/* > TOL is DOUBLE PRECISION */ +/* > TOL is the threshold for Jacobi rotations. For a pair */ +/* > A(:,p), A(:,q) of pivot columns, the Jacobi rotation is */ +/* > applied only if DABS(COS(angle(A(:,p),A(:,q)))) > TOL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NSWEEP */ +/* > \verbatim */ +/* > NSWEEP is INTEGER */ +/* > NSWEEP is the number of sweeps of Jacobi rotations to be */ +/* > performed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > LWORK is the dimension of WORK. LWORK >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, then the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */ + +/* ===================================================================== */ +/* Subroutine */ int dgsvj1_(char *jobv, integer *m, integer *n, integer *n1, + doublereal *a, integer *lda, doublereal *d__, doublereal *sva, + integer *mv, doublereal *v, integer *ldv, doublereal *eps, doublereal + *sfmin, doublereal *tol, integer *nsweep, doublereal *work, integer * + lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + doublereal d__1, d__2; + + /* Local variables */ + integer nblc; + doublereal aapp, aapq, aaqq; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + integer nblr, ierr; + doublereal bigtheta; + integer pskipped; + doublereal aapp0; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + doublereal temp1; + integer i__, p, q; + doublereal t, large, apoaq, aqoap; + extern logical lsame_(char *, char *); + doublereal theta, small; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal fastr[5]; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical applv, rsvec; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), drotm_(integer *, doublereal + *, integer *, doublereal *, integer *, doublereal *); + logical rotok; + doublereal rootsfmin, cs, sn; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer ijblsk, swband, blskip; + doublereal mxaapq; + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal thsign, mxsinj; + integer emptsw, notrot, iswrot, jbc; + doublereal big; + integer kbl, igl, ibr, jgl, mvl; + doublereal rootbig, rooteps; + integer rowskip; + doublereal roottol; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --sva; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + --work; + + /* Function Body */ + applv = lsame_(jobv, "A"); + rsvec = lsame_(jobv, "V"); + if (! (rsvec || applv || lsame_(jobv, "N"))) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0 || *n > *m) { + *info = -3; + } else if (*n1 < 0) { + *info = -4; + } else if (*lda < *m) { + *info = -6; + } else if ((rsvec || applv) && *mv < 0) { + *info = -9; + } else if (rsvec && *ldv < *n || applv && *ldv < *mv) { + *info = -11; + } else if (*tol <= *eps) { + *info = -14; + } else if (*nsweep < 0) { + *info = -15; + } else if (*lwork < *m) { + *info = -17; + } else { + *info = 0; + } + +/* #:( */ + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGSVJ1", &i__1, (ftnlen)6); + return 0; + } + + if (rsvec) { + mvl = *n; + } else if (applv) { + mvl = *mv; + } + rsvec = rsvec || applv; + rooteps = sqrt(*eps); + rootsfmin = sqrt(*sfmin); + small = *sfmin / *eps; + big = 1. / *sfmin; + rootbig = 1. / rootsfmin; + large = big / sqrt((doublereal) (*m * *n)); + bigtheta = 1. / rooteps; + roottol = sqrt(*tol); + + +/* RSVEC = LSAME( JOBV, 'Y' ) */ + + emptsw = *n1 * (*n - *n1); + notrot = 0; + fastr[0] = 0.; + + + kbl = f2cmin(8,*n); + nblr = *n1 / kbl; + if (nblr * kbl != *n1) { + ++nblr; + } + nblc = (*n - *n1) / kbl; + if (nblc * kbl != *n - *n1) { + ++nblc; + } +/* Computing 2nd power */ + i__1 = kbl; + blskip = i__1 * i__1 + 1; +/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */ + rowskip = f2cmin(5,kbl); +/* [TP] ROWSKIP is a tuning parameter. */ + swband = 0; +/* [TP] SWBAND is a tuning parameter. It is meaningful and effective */ +/* if SGESVJ is used as a computational routine in the preconditioned */ +/* Jacobi SVD algorithm SGESVJ. */ + + +/* | * * * [x] [x] [x]| */ +/* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. */ +/* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. */ +/* |[x] [x] [x] * * * | */ +/* |[x] [x] [x] * * * | */ +/* |[x] [x] [x] * * * | */ + + + i__1 = *nsweep; + for (i__ = 1; i__ <= i__1; ++i__) { + + mxaapq = 0.; + mxsinj = 0.; + iswrot = 0; + + notrot = 0; + pskipped = 0; + + i__2 = nblr; + for (ibr = 1; ibr <= i__2; ++ibr) { + igl = (ibr - 1) * kbl + 1; + + +/* ........................................................ */ +/* ... go to the off diagonal blocks */ + igl = (ibr - 1) * kbl + 1; + i__3 = nblc; + for (jbc = 1; jbc <= i__3; ++jbc) { + jgl = *n1 + (jbc - 1) * kbl + 1; +/* doing the block at ( ibr, jbc ) */ + ijblsk = 0; +/* Computing MIN */ + i__5 = igl + kbl - 1; + i__4 = f2cmin(i__5,*n1); + for (p = igl; p <= i__4; ++p) { + aapp = sva[p]; + if (aapp > 0.) { + pskipped = 0; +/* Computing MIN */ + i__6 = jgl + kbl - 1; + i__5 = f2cmin(i__6,*n); + for (q = jgl; q <= i__5; ++q) { + + aaqq = sva[q]; + if (aaqq > 0.) { + aapp0 = aapp; + + + + if (aaqq >= 1.) { + if (aapp >= aaqq) { + rotok = small * aapp <= aaqq; + } else { + rotok = small * aaqq <= aapp; + } + if (aapp < big / aaqq) { + aapq = ddot_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], & + c__1) * d__[p] * d__[q] / + aaqq / aapp; + } else { + dcopy_(m, &a[p * a_dim1 + 1], &c__1, & + work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aapp, & + d__[p], m, &c__1, &work[1], + lda, &ierr); + aapq = ddot_(m, &work[1], &c__1, &a[q + * a_dim1 + 1], &c__1) * d__[q] + / aaqq; + } + } else { + if (aapp >= aaqq) { + rotok = aapp <= aaqq / small; + } else { + rotok = aaqq <= aapp / small; + } + if (aapp > small / aaqq) { + aapq = ddot_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], & + c__1) * d__[p] * d__[q] / + aaqq / aapp; + } else { + dcopy_(m, &a[q * a_dim1 + 1], &c__1, & + work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aaqq, & + d__[q], m, &c__1, &work[1], + lda, &ierr); + aapq = ddot_(m, &work[1], &c__1, &a[p + * a_dim1 + 1], &c__1) * d__[p] + / aapp; + } + } +/* Computing MAX */ + d__1 = mxaapq, d__2 = abs(aapq); + mxaapq = f2cmax(d__1,d__2); +/* TO rotate or NOT to rotate, THAT is the question ... */ + + if (abs(aapq) > *tol) { + notrot = 0; +/* ROTATED = ROTATED + 1 */ + pskipped = 0; + ++iswrot; + + if (rotok) { + + aqoap = aaqq / aapp; + apoaq = aapp / aaqq; + theta = (d__1 = aqoap - apoaq, abs( + d__1)) * -.5 / aapq; + if (aaqq > aapp0) { + theta = -theta; + } + if (abs(theta) > bigtheta) { + t = .5 / theta; + fastr[2] = t * d__[p] / d__[q]; + fastr[3] = -t * d__[q] / d__[p]; + drotm_(m, &a[p * a_dim1 + 1], & + c__1, &a[q * a_dim1 + 1], + &c__1, fastr); + if (rsvec) { + drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * + v_dim1 + 1], &c__1, fastr); + } +/* Computing MAX */ + d__1 = 0., d__2 = t * apoaq * + aapq + 1.; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - t * aqoap * + aapq; + aapp *= sqrt((f2cmax(d__1,d__2))); +/* Computing MAX */ + d__1 = mxsinj, d__2 = abs(t); + mxsinj = f2cmax(d__1,d__2); + } else { + + + thsign = -d_sign(&c_b35, &aapq); + if (aaqq > aapp0) { + thsign = -thsign; + } + t = 1. / (theta + thsign * sqrt( + theta * theta + 1.)); + cs = sqrt(1. / (t * t + 1.)); + sn = t * cs; +/* Computing MAX */ + d__1 = mxsinj, d__2 = abs(sn); + mxsinj = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = 0., d__2 = t * apoaq * + aapq + 1.; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - t * aqoap * + aapq; + aapp *= sqrt((f2cmax(d__1,d__2))); + apoaq = d__[p] / d__[q]; + aqoap = d__[q] / d__[p]; + if (d__[p] >= 1.) { + + if (d__[q] >= 1.) { + fastr[2] = t * apoaq; + fastr[3] = -t * aqoap; + d__[p] *= cs; + d__[q] *= cs; + drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q * + a_dim1 + 1], &c__1, fastr); + if (rsvec) { + drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[ + q * v_dim1 + 1], &c__1, fastr); + } + } else { + d__1 = -t * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[ + p * a_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[ + q * a_dim1 + 1], &c__1); + if (rsvec) { + d__1 = -t * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], & + c__1, &v[p * v_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], & + c__1, &v[q * v_dim1 + 1], &c__1); + } + d__[p] *= cs; + d__[q] /= cs; + } + } else { + if (d__[q] >= 1.) { + d__1 = t * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[ + q * a_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[ + p * a_dim1 + 1], &c__1); + if (rsvec) { + d__1 = t * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], & + c__1, &v[q * v_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], & + c__1, &v[p * v_dim1 + 1], &c__1); + } + d__[p] /= cs; + d__[q] *= cs; + } else { + if (d__[p] >= d__[q]) { + d__1 = -t * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, + &a[p * a_dim1 + 1], &c__1); + d__1 = cs * sn * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, + &a[q * a_dim1 + 1], &c__1); + d__[p] *= cs; + d__[q] /= cs; + if (rsvec) { + d__1 = -t * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], + &c__1, &v[p * v_dim1 + 1], & + c__1); + d__1 = cs * sn * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], + &c__1, &v[q * v_dim1 + 1], & + c__1); + } + } else { + d__1 = t * apoaq; + daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, + &a[q * a_dim1 + 1], &c__1); + d__1 = -cs * sn * aqoap; + daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, + &a[p * a_dim1 + 1], &c__1); + d__[p] /= cs; + d__[q] *= cs; + if (rsvec) { + d__1 = t * apoaq; + daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], + &c__1, &v[q * v_dim1 + 1], & + c__1); + d__1 = -cs * sn * aqoap; + daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], + &c__1, &v[p * v_dim1 + 1], & + c__1); + } + } + } + } + } + } else { + if (aapp > aaqq) { + dcopy_(m, &a[p * a_dim1 + 1], & + c__1, &work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aapp, + &c_b35, m, &c__1, &work[1] + , lda, &ierr); + dlascl_("G", &c__0, &c__0, &aaqq, + &c_b35, m, &c__1, &a[q * + a_dim1 + 1], lda, &ierr); + temp1 = -aapq * d__[p] / d__[q]; + daxpy_(m, &temp1, &work[1], &c__1, + &a[q * a_dim1 + 1], & + c__1); + dlascl_("G", &c__0, &c__0, &c_b35, + &aaqq, m, &c__1, &a[q * + a_dim1 + 1], lda, &ierr); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - aapq * + aapq; + sva[q] = aaqq * sqrt((f2cmax(d__1, + d__2))); + mxsinj = f2cmax(mxsinj,*sfmin); + } else { + dcopy_(m, &a[q * a_dim1 + 1], & + c__1, &work[1], &c__1); + dlascl_("G", &c__0, &c__0, &aaqq, + &c_b35, m, &c__1, &work[1] + , lda, &ierr); + dlascl_("G", &c__0, &c__0, &aapp, + &c_b35, m, &c__1, &a[p * + a_dim1 + 1], lda, &ierr); + temp1 = -aapq * d__[q] / d__[p]; + daxpy_(m, &temp1, &work[1], &c__1, + &a[p * a_dim1 + 1], & + c__1); + dlascl_("G", &c__0, &c__0, &c_b35, + &aapp, m, &c__1, &a[p * + a_dim1 + 1], lda, &ierr); +/* Computing MAX */ + d__1 = 0., d__2 = 1. - aapq * + aapq; + sva[p] = aapp * sqrt((f2cmax(d__1, + d__2))); + mxsinj = f2cmax(mxsinj,*sfmin); + } + } +/* END IF ROTOK THEN ... ELSE */ + +/* In the case of cancellation in updating SVA(q) */ +/* Computing 2nd power */ + d__1 = sva[q] / aaqq; + if (d__1 * d__1 <= rooteps) { + if (aaqq < rootbig && aaqq > + rootsfmin) { + sva[q] = dnrm2_(m, &a[q * a_dim1 + + 1], &c__1) * d__[q]; + } else { + t = 0.; + aaqq = 1.; + dlassq_(m, &a[q * a_dim1 + 1], & + c__1, &t, &aaqq); + sva[q] = t * sqrt(aaqq) * d__[q]; + } + } +/* Computing 2nd power */ + d__1 = aapp / aapp0; + if (d__1 * d__1 <= rooteps) { + if (aapp < rootbig && aapp > + rootsfmin) { + aapp = dnrm2_(m, &a[p * a_dim1 + + 1], &c__1) * d__[p]; + } else { + t = 0.; + aapp = 1.; + dlassq_(m, &a[p * a_dim1 + 1], & + c__1, &t, &aapp); + aapp = t * sqrt(aapp) * d__[p]; + } + sva[p] = aapp; + } +/* end of OK rotation */ + } else { + ++notrot; +/* SKIPPED = SKIPPED + 1 */ + ++pskipped; + ++ijblsk; + } + } else { + ++notrot; + ++pskipped; + ++ijblsk; + } +/* IF ( NOTROT .GE. EMPTSW ) GO TO 2011 */ + if (i__ <= swband && ijblsk >= blskip) { + sva[p] = aapp; + notrot = 0; + goto L2011; + } + if (i__ <= swband && pskipped > rowskip) { + aapp = -aapp; + notrot = 0; + goto L2203; + } + +/* L2200: */ + } +/* end of the q-loop */ +L2203: + sva[p] = aapp; + + } else { + if (aapp == 0.) { +/* Computing MIN */ + i__5 = jgl + kbl - 1; + notrot = notrot + f2cmin(i__5,*n) - jgl + 1; + } + if (aapp < 0.) { + notrot = 0; + } +/* ** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 */ + } +/* L2100: */ + } +/* end of the p-loop */ +/* L2010: */ + } +/* end of the jbc-loop */ +L2011: +/* 2011 bailed out of the jbc-loop */ +/* Computing MIN */ + i__4 = igl + kbl - 1; + i__3 = f2cmin(i__4,*n); + for (p = igl; p <= i__3; ++p) { + sva[p] = (d__1 = sva[p], abs(d__1)); +/* L2012: */ + } +/* ** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 */ +/* L2000: */ + } +/* 2000 :: end of the ibr-loop */ + + if (sva[*n] < rootbig && sva[*n] > rootsfmin) { + sva[*n] = dnrm2_(m, &a[*n * a_dim1 + 1], &c__1) * d__[*n]; + } else { + t = 0.; + aapp = 1.; + dlassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp); + sva[*n] = t * sqrt(aapp) * d__[*n]; + } + +/* Additional steering devices */ + + if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) { + swband = i__; + } + if (i__ > swband + 1 && mxaapq < (doublereal) (*n) * *tol && ( + doublereal) (*n) * mxaapq * mxsinj < *tol) { + goto L1994; + } + + if (notrot >= emptsw) { + goto L1994; + } +/* L1993: */ + } +/* end i=1:NSWEEP loop */ +/* #:) Reaching this point means that the procedure has completed the given */ +/* number of sweeps. */ + *info = *nsweep - 1; + goto L1995; +L1994: +/* #:) Reaching this point means that during the i-th sweep all pivots were */ +/* below the given threshold, causing early exit. */ + *info = 0; +/* #:) INFO = 0 confirms successful iterations. */ +L1995: + +/* Sort the vector D */ + + i__1 = *n - 1; + for (p = 1; p <= i__1; ++p) { + i__2 = *n - p + 1; + q = idamax_(&i__2, &sva[p], &c__1) + p - 1; + if (p != q) { + temp1 = sva[p]; + sva[p] = sva[q]; + sva[q] = temp1; + temp1 = d__[p]; + d__[p] = d__[q]; + d__[q] = temp1; + dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1); + if (rsvec) { + dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], & + c__1); + } + } +/* L5991: */ + } + + return 0; +} /* dgsvj1_ */ + diff --git a/lapack-netlib/SRC/dgtcon.c b/lapack-netlib/SRC/dgtcon.c new file mode 100644 index 000000000..a23d7416a --- /dev/null +++ b/lapack-netlib/SRC/dgtcon.c @@ -0,0 +1,652 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGTCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGTCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER NORM */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGTCON estimates the reciprocal of the condition number of a real */ +/* > tridiagonal matrix A using the LU factorization as computed by */ +/* > DGTTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) multipliers that define the matrix L from the */ +/* > LU factorization of A as computed by DGTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the upper triangular matrix U from */ +/* > the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) elements of the first superdiagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU2 */ +/* > \verbatim */ +/* > DU2 is DOUBLE PRECISION array, dimension (N-2) */ +/* > The (n-2) elements of the second superdiagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* > interchanged with row IPIV(i). IPIV(i) will always be either */ +/* > i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* > required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > If NORM = '1' or 'O', the 1-norm of the original matrix A. */ +/* > If NORM = 'I', the infinity-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dgtcon_(char *norm, integer *n, doublereal *dl, + doublereal *d__, doublereal *du, doublereal *du2, integer *ipiv, + doublereal *anorm, doublereal *rcond, doublereal *work, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer kase, kase1, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + doublereal ainvnm; + logical onenrm; + extern /* Subroutine */ int dgttrs_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --iwork; + --work; + --ipiv; + --du2; + --du; + --d__; + --dl; + + /* Function Body */ + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*anorm < 0.) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + +/* Check that D(1:N) is non-zero. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] == 0.) { + return 0; + } +/* L10: */ + } + + ainvnm = 0.; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L20: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(U)*inv(L). */ + + dgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1] + , &ipiv[1], &work[1], n, info); + } else { + +/* Multiply by inv(L**T)*inv(U**T). */ + + dgttrs_("Transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1], & + ipiv[1], &work[1], n, info); + } + goto L20; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + + return 0; + +/* End of DGTCON */ + +} /* dgtcon_ */ + diff --git a/lapack-netlib/SRC/dgtrfs.c b/lapack-netlib/SRC/dgtrfs.c new file mode 100644 index 000000000..1f87bea87 --- /dev/null +++ b/lapack-netlib/SRC/dgtrfs.c @@ -0,0 +1,919 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGTRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGTRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, */ +/* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), */ +/* $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), */ +/* $ FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGTRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is tridiagonal, and provides */ +/* > error bounds and backward error estimates for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) superdiagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DLF */ +/* > \verbatim */ +/* > DLF is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) multipliers that define the matrix L from the */ +/* > LU factorization of A as computed by DGTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DF */ +/* > \verbatim */ +/* > DF is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the upper triangular matrix U from */ +/* > the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DUF */ +/* > \verbatim */ +/* > DUF is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) elements of the first superdiagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU2 */ +/* > \verbatim */ +/* > DU2 is DOUBLE PRECISION array, dimension (N-2) */ +/* > The (n-2) elements of the second superdiagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* > interchanged with row IPIV(i). IPIV(i) will always be either */ +/* > i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* > required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by DGTTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > ITMAX is the maximum number of steps of iterative refinement. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dgtrfs_(char *trans, integer *n, integer *nrhs, + doublereal *dl, doublereal *d__, doublereal *du, doublereal *dlf, + doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, + doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * + ferr, doublereal *berr, doublereal *work, integer *iwork, integer * + info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), daxpy_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + integer count; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + integer nz; + extern /* Subroutine */ int dlagtm_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transn[1]; + extern /* Subroutine */ int dgttrs_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *); + char transt[1]; + doublereal lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + --dlf; + --df; + --duf; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldx < f2cmax(1,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transn = 'N'; + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transn = 'T'; + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = 4; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dlagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j * + x_dim1 + 1], ldx, &c_b19, &work[*n + 1], n); + +/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */ +/* error bound. */ + + if (notran) { + if (*n == 1) { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)); + } else { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = du[1] * + x[j * x_dim1 + 2], abs(d__3)); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + ( + d__2 = dl[i__ - 1] * x[i__ - 1 + j * x_dim1], abs( + d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1], + abs(d__3)) + (d__4 = du[i__] * x[i__ + 1 + j * + x_dim1], abs(d__4)); +/* L30: */ + } + work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 = + dl[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + ( + d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3)); + } + } else { + if (*n == 1) { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)); + } else { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = dl[1] * + x[j * x_dim1 + 2], abs(d__3)); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + ( + d__2 = du[i__ - 1] * x[i__ - 1 + j * x_dim1], abs( + d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1], + abs(d__3)) + (d__4 = dl[i__] * x[i__ + 1 + j * + x_dim1], abs(d__4)); +/* L40: */ + } + work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 = + du[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + ( + d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3)); + } + } + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = f2cmax(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(d__2,d__3); + } +/* L50: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[ + 1], &work[*n + 1], n, info); + daxpy_(n, &c_b19, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L60: */ + } + + kase = 0; +L70: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + dgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & + ipiv[1], &work[*n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L80: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L90: */ + } + dgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & + ipiv[1], &work[*n + 1], n, info); + } + goto L70; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = f2cmax(d__2,d__3); +/* L100: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L110: */ + } + + return 0; + +/* End of DGTRFS */ + +} /* dgtrfs_ */ + diff --git a/lapack-netlib/SRC/dgtsv.c b/lapack-netlib/SRC/dgtsv.c new file mode 100644 index 000000000..3dd3e91f2 --- /dev/null +++ b/lapack-netlib/SRC/dgtsv.c @@ -0,0 +1,746 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGTSV computes the solution to system of linear equations A * X = B for GT matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGTSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) */ + +/* INTEGER INFO, LDB, N, NRHS */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGTSV solves the equation */ +/* > */ +/* > A*X = B, */ +/* > */ +/* > where A is an n by n tridiagonal matrix, by Gaussian elimination with */ +/* > partial pivoting. */ +/* > */ +/* > Note that the equation A**T*X = B may be solved by interchanging the */ +/* > order of the arguments DU and DL. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, DL must contain the (n-1) sub-diagonal elements of */ +/* > A. */ +/* > */ +/* > On exit, DL is overwritten by the (n-2) elements of the */ +/* > second super-diagonal of the upper triangular matrix U from */ +/* > the LU factorization of A, in DL(1), ..., DL(n-2). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, D must contain the diagonal elements of A. */ +/* > */ +/* > On exit, D is overwritten by the n diagonal elements of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, DU must contain the (n-1) super-diagonal elements */ +/* > of A. */ +/* > */ +/* > On exit, DU is overwritten by the (n-1) elements of the first */ +/* > super-diagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the N by NRHS matrix of right hand side matrix B. */ +/* > On exit, if INFO = 0, the N by NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, U(i,i) is exactly zero, and the solution */ +/* > has not been computed. The factorization has not been */ +/* > completed unless i = N. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGTsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, doublereal *dl, + doublereal *d__, doublereal *du, doublereal *b, integer *ldb, integer + *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + doublereal fact, temp; + integer i__, j; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --dl; + --d__; + --du; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTSV ", &i__1, (ftnlen)6); + return 0; + } + + if (*n == 0) { + return 0; + } + + if (*nrhs == 1) { + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + +/* No row interchange required */ + + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1]; + } else { + *info = i__; + return 0; + } + dl[i__] = 0.; + } else { + +/* Interchange rows I and I+1 */ + + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + dl[i__] = du[i__ + 1]; + du[i__ + 1] = -fact * dl[i__]; + du[i__] = temp; + temp = b[i__ + b_dim1]; + b[i__ + b_dim1] = b[i__ + 1 + b_dim1]; + b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1]; + } +/* L10: */ + } + if (*n > 1) { + i__ = *n - 1; + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1]; + } else { + *info = i__; + return 0; + } + } else { + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + du[i__] = temp; + temp = b[i__ + b_dim1]; + b[i__ + b_dim1] = b[i__ + 1 + b_dim1]; + b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1]; + } + } + if (d__[*n] == 0.) { + *info = *n; + return 0; + } + } else { + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + +/* No row interchange required */ + + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1]; +/* L20: */ + } + } else { + *info = i__; + return 0; + } + dl[i__] = 0.; + } else { + +/* Interchange rows I and I+1 */ + + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + dl[i__] = du[i__ + 1]; + du[i__ + 1] = -fact * dl[i__]; + du[i__] = temp; + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + temp = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j * + b_dim1]; +/* L30: */ + } + } +/* L40: */ + } + if (*n > 1) { + i__ = *n - 1; + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1]; +/* L50: */ + } + } else { + *info = i__; + return 0; + } + } else { + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + du[i__] = temp; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + temp = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j * + b_dim1]; +/* L60: */ + } + } + } + if (d__[*n] == 0.) { + *info = *n; + return 0; + } + } + +/* Back solve with the matrix U from the factorization. */ + + if (*nrhs <= 2) { + j = 1; +L70: + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] * b[ + *n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + 1 + + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) / d__[ + i__]; +/* L80: */ + } + if (j < *nrhs) { + ++j; + goto L70; + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] + * b[*n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + + 1 + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) + / d__[i__]; +/* L90: */ + } +/* L100: */ + } + } + + return 0; + +/* End of DGTSV */ + +} /* dgtsv_ */ + diff --git a/lapack-netlib/SRC/dgtsvx.c b/lapack-netlib/SRC/dgtsvx.c new file mode 100644 index 000000000..6beec1b28 --- /dev/null +++ b/lapack-netlib/SRC/dgtsvx.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 DGTSVX computes the solution to system of linear equations A * X = B for GT matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGTSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, */ +/* DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER FACT, TRANS */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), */ +/* $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), */ +/* $ FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGTSVX uses the LU factorization to compute the solution to a real */ +/* > system of linear equations A * X = B or A**T * X = B, */ +/* > where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */ +/* > as A = L * U, where L is a product of permutation and unit lower */ +/* > bidiagonal matrices and U is upper triangular with nonzeros in */ +/* > only the main diagonal and first two superdiagonals. */ +/* > */ +/* > 2. If some U(i,i)=0, so that U is exactly singular, then the routine */ +/* > returns with INFO = i. Otherwise, the factored form of A is used */ +/* > to estimate the condition number of the matrix A. If the */ +/* > reciprocal of the condition number is less than machine precision, */ +/* > INFO = N+1 is returned as a warning, but the routine still goes on */ +/* > to solve for X and compute error bounds as described below. */ +/* > */ +/* > 3. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 4. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of A has been */ +/* > supplied on entry. */ +/* > = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored */ +/* > form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV */ +/* > will not be modified. */ +/* > = 'N': The matrix will be copied to DLF, DF, and DUF */ +/* > and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) superdiagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DLF */ +/* > \verbatim */ +/* > DLF is DOUBLE PRECISION array, dimension (N-1) */ +/* > If FACT = 'F', then DLF is an input argument and on entry */ +/* > contains the (n-1) multipliers that define the matrix L from */ +/* > the LU factorization of A as computed by DGTTRF. */ +/* > */ +/* > If FACT = 'N', then DLF is an output argument and on exit */ +/* > contains the (n-1) multipliers that define the matrix L from */ +/* > the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DF */ +/* > \verbatim */ +/* > DF is DOUBLE PRECISION array, dimension (N) */ +/* > If FACT = 'F', then DF is an input argument and on entry */ +/* > contains the n diagonal elements of the upper triangular */ +/* > matrix U from the LU factorization of A. */ +/* > */ +/* > If FACT = 'N', then DF is an output argument and on exit */ +/* > contains the n diagonal elements of the upper triangular */ +/* > matrix U from the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DUF */ +/* > \verbatim */ +/* > DUF is DOUBLE PRECISION array, dimension (N-1) */ +/* > If FACT = 'F', then DUF is an input argument and on entry */ +/* > contains the (n-1) elements of the first superdiagonal of U. */ +/* > */ +/* > If FACT = 'N', then DUF is an output argument and on exit */ +/* > contains the (n-1) elements of the first superdiagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DU2 */ +/* > \verbatim */ +/* > DU2 is DOUBLE PRECISION array, dimension (N-2) */ +/* > If FACT = 'F', then DU2 is an input argument and on entry */ +/* > contains the (n-2) elements of the second superdiagonal of */ +/* > U. */ +/* > */ +/* > If FACT = 'N', then DU2 is an output argument and on exit */ +/* > contains the (n-2) elements of the second superdiagonal of */ +/* > U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains the pivot indices from the LU factorization of A as */ +/* > computed by DGTTRF. */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the LU factorization of A; */ +/* > row i of the matrix was interchanged with row IPIV(i). */ +/* > IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */ +/* > a row interchange was not required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The N-by-NRHS right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The estimate of the reciprocal condition number of the matrix */ +/* > A. If RCOND is less than the machine precision (in */ +/* > particular, if RCOND = 0), the matrix is singular to working */ +/* > precision. This condition is indicated by a return code of */ +/* > INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: U(i,i) is exactly zero. The factorization */ +/* > has not been completed unless i = N, but the */ +/* > factor U is exactly singular, so the solution */ +/* > and error bounds could not be computed. */ +/* > RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGTsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dgtsvx_(char *fact, char *trans, integer *n, integer * + nrhs, doublereal *dl, doublereal *d__, doublereal *du, doublereal * + dlf, doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, + doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * + rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1; + + /* Local variables */ + char norm[1]; + extern logical lsame_(char *, char *); + doublereal anorm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + extern doublereal dlamch_(char *), dlangt_(char *, integer *, + doublereal *, doublereal *, doublereal *); + logical nofact; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), dgtcon_(char *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, integer *), dgtrfs_(char *, integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *), dgttrf_(integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *); + logical notran; + extern /* Subroutine */ int dgttrs_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --dl; + --d__; + --du; + --dlf; + --df; + --duf; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + notran = lsame_(trans, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldb < f2cmax(1,*n)) { + *info = -14; + } else if (*ldx < f2cmax(1,*n)) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTSVX", &i__1, (ftnlen)6); + return 0; + } + + if (nofact) { + +/* Compute the LU factorization of A. */ + + dcopy_(n, &d__[1], &c__1, &df[1], &c__1); + if (*n > 1) { + i__1 = *n - 1; + dcopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &du[1], &c__1, &duf[1], &c__1); + } + dgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + if (notran) { + *(unsigned char *)norm = '1'; + } else { + *(unsigned char *)norm = 'I'; + } + anorm = dlangt_(norm, n, &dl[1], &d__[1], &du[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm, + rcond, &work[1], &iwork[1], info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + dgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1], + &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1] + , &berr[1], &work[1], &iwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DGTSVX */ + +} /* dgtsvx_ */ + diff --git a/lapack-netlib/SRC/dgttrf.c b/lapack-netlib/SRC/dgttrf.c new file mode 100644 index 000000000..855df6eb5 --- /dev/null +++ b/lapack-netlib/SRC/dgttrf.c @@ -0,0 +1,632 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGTTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGTTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) */ + +/* INTEGER INFO, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGTTRF computes an LU factorization of a real tridiagonal matrix A */ +/* > using elimination with partial pivoting and row interchanges. */ +/* > */ +/* > The factorization has the form */ +/* > A = L * U */ +/* > where L is a product of permutation and unit lower bidiagonal */ +/* > matrices and U is upper triangular with nonzeros in only the main */ +/* > diagonal and first two superdiagonals. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, DL must contain the (n-1) sub-diagonal elements of */ +/* > A. */ +/* > */ +/* > On exit, DL is overwritten by the (n-1) multipliers that */ +/* > define the matrix L from the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, D must contain the diagonal elements of A. */ +/* > */ +/* > On exit, D is overwritten by the n diagonal elements of the */ +/* > upper triangular matrix U from the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, DU must contain the (n-1) super-diagonal elements */ +/* > of A. */ +/* > */ +/* > On exit, DU is overwritten by the (n-1) elements of the first */ +/* > super-diagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DU2 */ +/* > \verbatim */ +/* > DU2 is DOUBLE PRECISION array, dimension (N-2) */ +/* > On exit, DU2 is overwritten by the (n-2) elements of the */ +/* > second super-diagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* > interchanged with row IPIV(i). IPIV(i) will always be either */ +/* > i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* > required. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, U(k,k) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, and division by zero will occur if it is used */ +/* > to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dgttrf_(integer *n, doublereal *dl, doublereal *d__, + doublereal *du, doublereal *du2, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2; + + /* Local variables */ + doublereal fact, temp; + integer i__; + 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --ipiv; + --du2; + --du; + --d__; + --dl; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("DGTTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Initialize IPIV(i) = i and DU2(I) = 0 */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ipiv[i__] = i__; +/* L10: */ + } + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + du2[i__] = 0.; +/* L20: */ + } + + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + +/* No row interchange required, eliminate DL(I) */ + + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + dl[i__] = fact; + d__[i__ + 1] -= fact * du[i__]; + } + } else { + +/* Interchange rows I and I+1, eliminate DL(I) */ + + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + dl[i__] = fact; + temp = du[i__]; + du[i__] = d__[i__ + 1]; + d__[i__ + 1] = temp - fact * d__[i__ + 1]; + du2[i__] = du[i__ + 1]; + du[i__ + 1] = -fact * du[i__ + 1]; + ipiv[i__] = i__ + 1; + } +/* L30: */ + } + if (*n > 1) { + i__ = *n - 1; + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + dl[i__] = fact; + d__[i__ + 1] -= fact * du[i__]; + } + } else { + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + dl[i__] = fact; + temp = du[i__]; + du[i__] = d__[i__ + 1]; + d__[i__ + 1] = temp - fact * d__[i__ + 1]; + ipiv[i__] = i__ + 1; + } + } + +/* Check for a zero on the diagonal of U. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] == 0.) { + *info = i__; + goto L50; + } +/* L40: */ + } +L50: + + return 0; + +/* End of DGTTRF */ + +} /* dgttrf_ */ + diff --git a/lapack-netlib/SRC/dgttrs.c b/lapack-netlib/SRC/dgttrs.c new file mode 100644 index 000000000..b0f951a4d --- /dev/null +++ b/lapack-netlib/SRC/dgttrs.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 DGTTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGTTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, */ +/* INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER INFO, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGTTRS solves one of the systems of equations */ +/* > A*X = B or A**T*X = B, */ +/* > with a tridiagonal matrix A using the LU factorization computed */ +/* > by DGTTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations. */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T* X = B (Transpose) */ +/* > = 'C': A**T* X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) multipliers that define the matrix L from the */ +/* > LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the upper triangular matrix U from */ +/* > the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) elements of the first super-diagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU2 */ +/* > \verbatim */ +/* > DU2 is DOUBLE PRECISION array, dimension (N-2) */ +/* > The (n-2) elements of the second super-diagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* > interchanged with row IPIV(i). IPIV(i) will always be either */ +/* > i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* > required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the matrix of right hand side vectors B. */ +/* > On exit, B is overwritten by the solution vectors X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -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 doubleGTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dgttrs_(char *trans, integer *n, integer *nrhs, + doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2, + integer *ipiv, doublereal *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer j; + extern /* Subroutine */ int dgtts2_(integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer jb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer itrans; + logical notran; + + +/* -- 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 */ + --dl; + --d__; + --du; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + notran = *(unsigned char *)trans == 'N' || *(unsigned char *)trans == 'n'; + if (! notran && ! (*(unsigned char *)trans == 'T' || *(unsigned char *) + trans == 't') && ! (*(unsigned char *)trans == 'C' || *(unsigned + char *)trans == 'c')) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(*n,1)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Decode TRANS */ + + if (notran) { + itrans = 0; + } else { + itrans = 1; + } + +/* Determine the number of right-hand sides to solve at a time. */ + + if (*nrhs == 1) { + nb = 1; + } else { +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "DGTTRS", trans, n, nrhs, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nb = f2cmax(i__1,i__2); + } + + if (nb >= *nrhs) { + dgtts2_(&itrans, n, nrhs, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[1], + &b[b_offset], ldb); + } else { + i__1 = *nrhs; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nrhs - j + 1; + jb = f2cmin(i__3,nb); + dgtts2_(&itrans, n, &jb, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[ + 1], &b[j * b_dim1 + 1], ldb); +/* L10: */ + } + } + +/* End of DGTTRS */ + + return 0; +} /* dgttrs_ */ + diff --git a/lapack-netlib/SRC/dgtts2.c b/lapack-netlib/SRC/dgtts2.c new file mode 100644 index 000000000..6ba562604 --- /dev/null +++ b/lapack-netlib/SRC/dgtts2.c @@ -0,0 +1,706 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGTTS2 solves a system of linear equations with a tridiagonal matrix using the LU factorization + computed by sgttrf. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGTTS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) */ + +/* INTEGER ITRANS, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGTTS2 solves one of the systems of equations */ +/* > A*X = B or A**T*X = B, */ +/* > with a tridiagonal matrix A using the LU factorization computed */ +/* > by DGTTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITRANS */ +/* > \verbatim */ +/* > ITRANS is INTEGER */ +/* > Specifies the form of the system of equations. */ +/* > = 0: A * X = B (No transpose) */ +/* > = 1: A**T* X = B (Transpose) */ +/* > = 2: A**T* X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) multipliers that define the matrix L from the */ +/* > LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the upper triangular matrix U from */ +/* > the LU factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) elements of the first super-diagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU2 */ +/* > \verbatim */ +/* > DU2 is DOUBLE PRECISION array, dimension (N-2) */ +/* > The (n-2) elements of the second super-diagonal of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* > interchanged with row IPIV(i). IPIV(i) will always be either */ +/* > i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* > required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the matrix of right hand side vectors B. */ +/* > On exit, B is overwritten by the solution vectors X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dgtts2_(integer *itrans, integer *n, integer *nrhs, + doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2, + integer *ipiv, doublereal *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + doublereal temp; + integer i__, j, ip; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (*itrans == 0) { + +/* Solve A*X = B using the LU factorization of A, */ +/* overwriting each right hand side vector with its solution. */ + + if (*nrhs <= 1) { + j = 1; +L10: + +/* Solve L*x = b. */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + ip = ipiv[i__]; + temp = b[i__ + 1 - ip + i__ + j * b_dim1] - dl[i__] * b[ip + + j * b_dim1]; + b[i__ + j * b_dim1] = b[ip + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp; +/* L20: */ + } + +/* Solve U*x = b. */ + + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] + * b[*n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * b_dim1] + ) / d__[i__]; +/* L30: */ + } + if (j < *nrhs) { + ++j; + goto L10; + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve L*x = b. */ + + i__2 = *n - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (ipiv[i__] == i__) { + b[i__ + 1 + j * b_dim1] -= dl[i__] * b[i__ + j * + b_dim1]; + } else { + temp = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp - dl[i__] * b[i__ + j * + b_dim1]; + } +/* L40: */ + } + +/* Solve U*x = b. */ + + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n + - 1] * b[*n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[ + i__ + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * + b_dim1]) / d__[i__]; +/* L50: */ + } +/* L60: */ + } + } + } else { + +/* Solve A**T * X = B. */ + + if (*nrhs <= 1) { + +/* Solve U**T*x = b. */ + + j = 1; +L70: + b[j * b_dim1 + 1] /= d__[1]; + if (*n > 1) { + b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * b_dim1 + + 1]) / d__[2]; + } + i__1 = *n; + for (i__ = 3; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * b[ + i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - 2 + j * + b_dim1]) / d__[i__]; +/* L80: */ + } + +/* Solve L**T*x = b. */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + ip = ipiv[i__]; + temp = b[i__ + j * b_dim1] - dl[i__] * b[i__ + 1 + j * b_dim1] + ; + b[i__ + j * b_dim1] = b[ip + j * b_dim1]; + b[ip + j * b_dim1] = temp; +/* L90: */ + } + if (j < *nrhs) { + ++j; + goto L70; + } + + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve U**T*x = b. */ + + b[j * b_dim1 + 1] /= d__[1]; + if (*n > 1) { + b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * + b_dim1 + 1]) / d__[2]; + } + i__2 = *n; + for (i__ = 3; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * + b[i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - + 2 + j * b_dim1]) / d__[i__]; +/* L100: */ + } + for (i__ = *n - 1; i__ >= 1; --i__) { + if (ipiv[i__] == i__) { + b[i__ + j * b_dim1] -= dl[i__] * b[i__ + 1 + j * + b_dim1]; + } else { + temp = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - dl[ + i__] * temp; + b[i__ + j * b_dim1] = temp; + } +/* L110: */ + } +/* L120: */ + } + } + } + +/* End of DGTTS2 */ + + return 0; +} /* dgtts2_ */ + diff --git a/lapack-netlib/SRC/dhgeqz.c b/lapack-netlib/SRC/dhgeqz.c new file mode 100644 index 000000000..1081305ca --- /dev/null +++ b/lapack-netlib/SRC/dhgeqz.c @@ -0,0 +1,1985 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DHGEQZ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DHGEQZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, */ +/* ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER COMPQ, COMPZ, JOB */ +/* INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N */ +/* DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), */ +/* $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DHGEQZ computes the eigenvalues of a real matrix pair (H,T), */ +/* > where H is an upper Hessenberg matrix and T is upper triangular, */ +/* > using the double-shift QZ method. */ +/* > Matrix pairs of this type are produced by the reduction to */ +/* > generalized upper Hessenberg form of a real matrix pair (A,B): */ +/* > */ +/* > A = Q1*H*Z1**T, B = Q1*T*Z1**T, */ +/* > */ +/* > as computed by DGGHRD. */ +/* > */ +/* > If JOB='S', then the Hessenberg-triangular pair (H,T) is */ +/* > also reduced to generalized Schur form, */ +/* > */ +/* > H = Q*S*Z**T, T = Q*P*Z**T, */ +/* > */ +/* > where Q and Z are orthogonal matrices, P is an upper triangular */ +/* > matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 */ +/* > diagonal blocks. */ +/* > */ +/* > The 1-by-1 blocks correspond to real eigenvalues of the matrix pair */ +/* > (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of */ +/* > eigenvalues. */ +/* > */ +/* > Additionally, the 2-by-2 upper triangular diagonal blocks of P */ +/* > corresponding to 2-by-2 blocks of S are reduced to positive diagonal */ +/* > form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, */ +/* > P(j,j) > 0, and P(j+1,j+1) > 0. */ +/* > */ +/* > Optionally, the orthogonal matrix Q from the generalized Schur */ +/* > factorization may be postmultiplied into an input matrix Q1, and the */ +/* > orthogonal matrix Z may be postmultiplied into an input matrix Z1. */ +/* > If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced */ +/* > the matrix pair (A,B) to generalized upper Hessenberg form, then the */ +/* > output matrices Q1*Q and Z1*Z are the orthogonal factors from the */ +/* > generalized Schur factorization of (A,B): */ +/* > */ +/* > A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. */ +/* > */ +/* > To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, */ +/* > of (A,B)) are computed as a pair of values (alpha,beta), where alpha is */ +/* > complex and beta real. */ +/* > If beta is nonzero, lambda = alpha / beta is an eigenvalue of the */ +/* > generalized nonsymmetric eigenvalue problem (GNEP) */ +/* > A*x = lambda*B*x */ +/* > and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */ +/* > alternate form of the GNEP */ +/* > mu*A*y = B*y. */ +/* > Real eigenvalues can be read directly from the generalized Schur */ +/* > form: */ +/* > alpha = S(i,i), beta = P(i,i). */ +/* > */ +/* > Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */ +/* > Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */ +/* > pp. 241--256. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > = 'E': Compute eigenvalues only; */ +/* > = 'S': Compute eigenvalues and the Schur form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'N': Left Schur vectors (Q) are not computed; */ +/* > = 'I': Q is initialized to the unit matrix and the matrix Q */ +/* > of left Schur vectors of (H,T) is returned; */ +/* > = 'V': Q must contain an orthogonal matrix Q1 on entry and */ +/* > the product Q1*Q is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Right Schur vectors (Z) are not computed; */ +/* > = 'I': Z is initialized to the unit matrix and the matrix Z */ +/* > of right Schur vectors of (H,T) is returned; */ +/* > = 'V': Z must contain an orthogonal matrix Z1 on entry and */ +/* > the product Z1*Z is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices H, T, Q, and Z. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > ILO and IHI mark the rows and columns of H which are in */ +/* > Hessenberg form. It is assumed that A is already upper */ +/* > triangular in rows and columns 1:ILO-1 and IHI+1:N. */ +/* > If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is DOUBLE PRECISION array, dimension (LDH, N) */ +/* > On entry, the N-by-N upper Hessenberg matrix H. */ +/* > On exit, if JOB = 'S', H contains the upper quasi-triangular */ +/* > matrix S from the generalized Schur factorization. */ +/* > If JOB = 'E', the diagonal blocks of H match those of S, but */ +/* > the rest of H is unspecified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT, N) */ +/* > On entry, the N-by-N upper triangular matrix T. */ +/* > On exit, if JOB = 'S', T contains the upper triangular */ +/* > matrix P from the generalized Schur factorization; */ +/* > 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S */ +/* > are reduced to positive diagonal form, i.e., if H(j+1,j) is */ +/* > non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and */ +/* > T(j+1,j+1) > 0. */ +/* > If JOB = 'E', the diagonal blocks of T match those of P, but */ +/* > the rest of T is unspecified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > The real parts of each scalar alpha defining an eigenvalue */ +/* > of GNEP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > The imaginary parts of each scalar alpha defining an */ +/* > eigenvalue of GNEP. */ +/* > If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* > positive, then the j-th and (j+1)-st eigenvalues are a */ +/* > complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > The scalars beta that define the eigenvalues of GNEP. */ +/* > Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* > beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* > pair (A,B), in one of the forms lambda = alpha/beta or */ +/* > mu = beta/alpha. Since either lambda or mu may overflow, */ +/* > they should not, in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */ +/* > On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in */ +/* > the reduction of (A,B) to generalized Hessenberg form. */ +/* > On exit, if COMPQ = 'I', the orthogonal matrix of left Schur */ +/* > vectors of (H,T), and if COMPQ = 'V', the orthogonal matrix */ +/* > of left Schur vectors of (A,B). */ +/* > Not referenced if COMPQ = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1. */ +/* > If COMPQ='V' or 'I', then LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in */ +/* > the reduction of (A,B) to generalized Hessenberg form. */ +/* > On exit, if COMPZ = 'I', the orthogonal matrix of */ +/* > right Schur vectors of (H,T), and if COMPZ = 'V', the */ +/* > orthogonal matrix of right Schur vectors of (A,B). */ +/* > Not referenced if COMPZ = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If COMPZ='V' or 'I', then LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1,...,N: the QZ iteration did not converge. (H,T) is not */ +/* > in Schur form, but ALPHAR(i), ALPHAI(i), and */ +/* > BETA(i), i=INFO+1,...,N should be correct. */ +/* > = N+1,...,2*N: the shift calculation failed. (H,T) is not */ +/* > in Schur form, but ALPHAR(i), ALPHAI(i), and */ +/* > BETA(i), i=INFO-N+1,...,N should be correct. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleGEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Iteration counters: */ +/* > */ +/* > JITER -- counts iterations. */ +/* > IITER -- counts iterations run since ILAST was last */ +/* > changed. This is therefore reset only when a 1-by-1 or */ +/* > 2-by-2 block deflates off the bottom. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dhgeqz_(char *job, char *compq, char *compz, integer *n, + integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal + *t, integer *ldt, doublereal *alphar, doublereal *alphai, doublereal * + beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz, + doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1, + z_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal ad11l, ad12l, ad21l, ad22l, ad32l, wabs, atol, btol, temp; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *), dlag2_( + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + doublereal temp2, s1inv, c__; + integer j; + doublereal s, v[3], scale; + extern logical lsame_(char *, char *); + integer iiter, ilast, jiter; + doublereal anorm, bnorm; + integer maxit; + doublereal tempi, tempr, s1, s2, t1, u1, u2; + extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal + *, doublereal *, doublereal *); + extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + logical ilazr2; + doublereal a11, a12, a21, a22, b11, b22, c12, c21; + integer jc; + doublereal an, bn, cl, cq, cr; + integer in; + doublereal ascale, bscale, u12, w11; + integer jr; + doublereal cz, sl, w12, w21, w22, wi; + extern doublereal dlamch_(char *); + doublereal sr; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *); + doublereal vs, wr; + extern doublereal dlanhs_(char *, integer *, doublereal *, integer *, + doublereal *); + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + doublereal safmax; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal eshift; + logical ilschr; + doublereal b1a, b2a; + integer icompq, ilastm; + doublereal a1i; + integer ischur; + doublereal a2i, b1i; + logical ilazro; + integer icompz, ifirst; + doublereal b2i; + integer ifrstm; + doublereal a1r; + integer istart; + logical ilpivt; + doublereal a2r, b1r, b2r; + logical lquery; + doublereal wr2, ad11, ad12, ad21, ad22, c11i, c22i; + integer jch; + doublereal c11r, c22r; + logical ilq; + doublereal u12l, tau, sqi; + logical ilz; + doublereal ulp, sqr, szi, szr; + + +/* -- 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 */ + + +/* ===================================================================== */ + +/* $ SAFETY = 1.0E+0 ) */ + +/* Decode JOB, COMPQ, COMPZ */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --alphar; + --alphai; + --beta; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + if (lsame_(job, "E")) { + ilschr = FALSE_; + ischur = 1; + } else if (lsame_(job, "S")) { + ilschr = TRUE_; + ischur = 2; + } else { + ischur = 0; + } + + if (lsame_(compq, "N")) { + ilq = FALSE_; + icompq = 1; + } else if (lsame_(compq, "V")) { + ilq = TRUE_; + icompq = 2; + } else if (lsame_(compq, "I")) { + ilq = TRUE_; + icompq = 3; + } else { + icompq = 0; + } + + if (lsame_(compz, "N")) { + ilz = FALSE_; + icompz = 1; + } else if (lsame_(compz, "V")) { + ilz = TRUE_; + icompz = 2; + } else if (lsame_(compz, "I")) { + ilz = TRUE_; + icompz = 3; + } else { + icompz = 0; + } + +/* Check Argument Values */ + + *info = 0; + work[1] = (doublereal) f2cmax(1,*n); + lquery = *lwork == -1; + if (ischur == 0) { + *info = -1; + } else if (icompq == 0) { + *info = -2; + } else if (icompz == 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ilo < 1) { + *info = -5; + } else if (*ihi > *n || *ihi < *ilo - 1) { + *info = -6; + } else if (*ldh < *n) { + *info = -8; + } else if (*ldt < *n) { + *info = -10; + } else if (*ldq < 1 || ilq && *ldq < *n) { + *info = -15; + } else if (*ldz < 1 || ilz && *ldz < *n) { + *info = -17; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DHGEQZ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1] = 1.; + return 0; + } + +/* Initialize Q and Z */ + + if (icompq == 3) { + dlaset_("Full", n, n, &c_b12, &c_b13, &q[q_offset], ldq); + } + if (icompz == 3) { + dlaset_("Full", n, n, &c_b12, &c_b13, &z__[z_offset], ldz); + } + +/* Machine Constants */ + + in = *ihi + 1 - *ilo; + safmin = dlamch_("S"); + safmax = 1. / safmin; + ulp = dlamch_("E") * dlamch_("B"); + anorm = dlanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &work[1]); + bnorm = dlanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &work[1]); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * anorm; + atol = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * bnorm; + btol = f2cmax(d__1,d__2); + ascale = 1. / f2cmax(safmin,anorm); + bscale = 1. / f2cmax(safmin,bnorm); + +/* Set Eigenvalues IHI+1:N */ + + i__1 = *n; + for (j = *ihi + 1; j <= i__1; ++j) { + if (t[j + j * t_dim1] < 0.) { + if (ilschr) { + i__2 = j; + for (jr = 1; jr <= i__2; ++jr) { + h__[jr + j * h_dim1] = -h__[jr + j * h_dim1]; + t[jr + j * t_dim1] = -t[jr + j * t_dim1]; +/* L10: */ + } + } else { + h__[j + j * h_dim1] = -h__[j + j * h_dim1]; + t[j + j * t_dim1] = -t[j + j * t_dim1]; + } + if (ilz) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + z__[jr + j * z_dim1] = -z__[jr + j * z_dim1]; +/* L20: */ + } + } + } + alphar[j] = h__[j + j * h_dim1]; + alphai[j] = 0.; + beta[j] = t[j + j * t_dim1]; +/* L30: */ + } + +/* If IHI < ILO, skip QZ steps */ + + if (*ihi < *ilo) { + goto L380; + } + +/* MAIN QZ ITERATION LOOP */ + +/* Initialize dynamic indices */ + +/* Eigenvalues ILAST+1:N have been found. */ +/* Column operations modify rows IFRSTM:whatever. */ +/* Row operations modify columns whatever:ILASTM. */ + +/* If only eigenvalues are being computed, then */ +/* IFRSTM is the row of the last splitting row above row ILAST; */ +/* this is always at least ILO. */ +/* IITER counts iterations since the last eigenvalue was found, */ +/* to tell when to use an extraordinary shift. */ +/* MAXIT is the maximum number of QZ sweeps allowed. */ + + ilast = *ihi; + if (ilschr) { + ifrstm = 1; + ilastm = *n; + } else { + ifrstm = *ilo; + ilastm = *ihi; + } + iiter = 0; + eshift = 0.; + maxit = (*ihi - *ilo + 1) * 30; + + i__1 = maxit; + for (jiter = 1; jiter <= i__1; ++jiter) { + +/* Split the matrix if possible. */ + +/* Two tests: */ +/* 1: H(j,j-1)=0 or j=ILO */ +/* 2: T(j,j)=0 */ + + if (ilast == *ilo) { + +/* Special case: j=ILAST */ + + goto L80; + } else { + if ((d__1 = h__[ilast + (ilast - 1) * h_dim1], abs(d__1)) <= atol) + { + h__[ilast + (ilast - 1) * h_dim1] = 0.; + goto L80; + } + } + + if ((d__1 = t[ilast + ilast * t_dim1], abs(d__1)) <= btol) { + t[ilast + ilast * t_dim1] = 0.; + goto L70; + } + +/* General case: j= i__2; --j) { + +/* Test 1: for H(j,j-1)=0 or j=ILO */ + + if (j == *ilo) { + ilazro = TRUE_; + } else { + if ((d__1 = h__[j + (j - 1) * h_dim1], abs(d__1)) <= atol) { + h__[j + (j - 1) * h_dim1] = 0.; + ilazro = TRUE_; + } else { + ilazro = FALSE_; + } + } + +/* Test 2: for T(j,j)=0 */ + + if ((d__1 = t[j + j * t_dim1], abs(d__1)) < btol) { + t[j + j * t_dim1] = 0.; + +/* Test 1a: Check for 2 consecutive small subdiagonals in A */ + + ilazr2 = FALSE_; + if (! ilazro) { + temp = (d__1 = h__[j + (j - 1) * h_dim1], abs(d__1)); + temp2 = (d__1 = h__[j + j * h_dim1], abs(d__1)); + tempr = f2cmax(temp,temp2); + if (tempr < 1. && tempr != 0.) { + temp /= tempr; + temp2 /= tempr; + } + if (temp * (ascale * (d__1 = h__[j + 1 + j * h_dim1], abs( + d__1))) <= temp2 * (ascale * atol)) { + ilazr2 = TRUE_; + } + } + +/* If both tests pass (1 & 2), i.e., the leading diagonal */ +/* element of B in the block is zero, split a 1x1 block off */ +/* at the top. (I.e., at the J-th row/column) The leading */ +/* diagonal element of the remainder can also be zero, so */ +/* this may have to be done repeatedly. */ + + if (ilazro || ilazr2) { + i__3 = ilast - 1; + for (jch = j; jch <= i__3; ++jch) { + temp = h__[jch + jch * h_dim1]; + dlartg_(&temp, &h__[jch + 1 + jch * h_dim1], &c__, &s, + &h__[jch + jch * h_dim1]); + h__[jch + 1 + jch * h_dim1] = 0.; + i__4 = ilastm - jch; + drot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, & + h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__, + &s); + i__4 = ilastm - jch; + drot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[ + jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s); + if (ilq) { + drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) + * q_dim1 + 1], &c__1, &c__, &s); + } + if (ilazr2) { + h__[jch + (jch - 1) * h_dim1] *= c__; + } + ilazr2 = FALSE_; + if ((d__1 = t[jch + 1 + (jch + 1) * t_dim1], abs(d__1) + ) >= btol) { + if (jch + 1 >= ilast) { + goto L80; + } else { + ifirst = jch + 1; + goto L110; + } + } + t[jch + 1 + (jch + 1) * t_dim1] = 0.; +/* L40: */ + } + goto L70; + } else { + +/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */ +/* Then process as in the case T(ILAST,ILAST)=0 */ + + i__3 = ilast - 1; + for (jch = j; jch <= i__3; ++jch) { + temp = t[jch + (jch + 1) * t_dim1]; + dlartg_(&temp, &t[jch + 1 + (jch + 1) * t_dim1], &c__, + &s, &t[jch + (jch + 1) * t_dim1]); + t[jch + 1 + (jch + 1) * t_dim1] = 0.; + if (jch < ilastm - 1) { + i__4 = ilastm - jch - 1; + drot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, & + t[jch + 1 + (jch + 2) * t_dim1], ldt, & + c__, &s); + } + i__4 = ilastm - jch + 2; + drot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, & + h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__, + &s); + if (ilq) { + drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) + * q_dim1 + 1], &c__1, &c__, &s); + } + temp = h__[jch + 1 + jch * h_dim1]; + dlartg_(&temp, &h__[jch + 1 + (jch - 1) * h_dim1], & + c__, &s, &h__[jch + 1 + jch * h_dim1]); + h__[jch + 1 + (jch - 1) * h_dim1] = 0.; + i__4 = jch + 1 - ifrstm; + drot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[ + ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s) + ; + i__4 = jch - ifrstm; + drot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[ + ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s) + ; + if (ilz) { + drot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch + - 1) * z_dim1 + 1], &c__1, &c__, &s); + } +/* L50: */ + } + goto L70; + } + } else if (ilazro) { + +/* Only test 1 passed -- work on J:ILAST */ + + ifirst = j; + goto L110; + } + +/* Neither test passed -- try next J */ + +/* L60: */ + } + +/* (Drop-through is "impossible") */ + + *info = *n + 1; + goto L420; + +/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */ +/* 1x1 block. */ + +L70: + temp = h__[ilast + ilast * h_dim1]; + dlartg_(&temp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[ + ilast + ilast * h_dim1]); + h__[ilast + (ilast - 1) * h_dim1] = 0.; + i__2 = ilast - ifrstm; + drot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + ( + ilast - 1) * h_dim1], &c__1, &c__, &s); + i__2 = ilast - ifrstm; + drot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast - + 1) * t_dim1], &c__1, &c__, &s); + if (ilz) { + drot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) * + z_dim1 + 1], &c__1, &c__, &s); + } + +/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, */ +/* and BETA */ + +L80: + if (t[ilast + ilast * t_dim1] < 0.) { + if (ilschr) { + i__2 = ilast; + for (j = ifrstm; j <= i__2; ++j) { + h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1]; + t[j + ilast * t_dim1] = -t[j + ilast * t_dim1]; +/* L90: */ + } + } else { + h__[ilast + ilast * h_dim1] = -h__[ilast + ilast * h_dim1]; + t[ilast + ilast * t_dim1] = -t[ilast + ilast * t_dim1]; + } + if (ilz) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1]; +/* L100: */ + } + } + } + alphar[ilast] = h__[ilast + ilast * h_dim1]; + alphai[ilast] = 0.; + beta[ilast] = t[ilast + ilast * t_dim1]; + +/* Go to next block -- exit if finished. */ + + --ilast; + if (ilast < *ilo) { + goto L380; + } + +/* Reset counters */ + + iiter = 0; + eshift = 0.; + if (! ilschr) { + ilastm = ilast; + if (ifrstm > ilast) { + ifrstm = *ilo; + } + } + goto L350; + +/* QZ step */ + +/* This iteration only involves rows/columns IFIRST:ILAST. We */ +/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */ + +L110: + ++iiter; + if (! ilschr) { + ifrstm = ifirst; + } + +/* Compute single shifts. */ + +/* At this point, IFIRST < ILAST, and the diagonal elements of */ +/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */ +/* magnitude) */ + + if (iiter / 10 * 10 == iiter) { + +/* Exceptional shift. Chosen for no particularly good reason. */ +/* (Single shift only.) */ + + if ((doublereal) maxit * safmin * (d__1 = h__[ilast + (ilast - 1) + * h_dim1], abs(d__1)) < (d__2 = t[ilast - 1 + (ilast - 1) + * t_dim1], abs(d__2))) { + eshift = h__[ilast + (ilast - 1) * h_dim1] / t[ilast - 1 + ( + ilast - 1) * t_dim1]; + } else { + eshift += 1. / (safmin * (doublereal) maxit); + } + s1 = 1.; + wr = eshift; + + } else { + +/* Shifts based on the generalized eigenvalues of the */ +/* bottom-right 2x2 block of A and B. The first eigenvalue */ +/* returned by DLAG2 is the Wilkinson shift (AEP p.512), */ + + d__1 = safmin * 100.; + dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1 + + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &s2, &wr, &wr2, + &wi); + + if ((d__1 = wr / s1 * t[ilast + ilast * t_dim1] - h__[ilast + + ilast * h_dim1], abs(d__1)) > (d__2 = wr2 / s2 * t[ilast + + ilast * t_dim1] - h__[ilast + ilast * h_dim1], abs(d__2) + )) { + temp = wr; + wr = wr2; + wr2 = temp; + temp = s1; + s1 = s2; + s2 = temp; + } +/* Computing MAX */ +/* Computing MAX */ + d__3 = 1., d__4 = abs(wr), d__3 = f2cmax(d__3,d__4), d__4 = abs(wi); + d__1 = s1, d__2 = safmin * f2cmax(d__3,d__4); + temp = f2cmax(d__1,d__2); + if (wi != 0.) { + goto L200; + } + } + +/* Fiddle with shift to avoid overflow */ + + temp = f2cmin(ascale,1.) * (safmax * .5); + if (s1 > temp) { + scale = temp / s1; + } else { + scale = 1.; + } + + temp = f2cmin(bscale,1.) * (safmax * .5); + if (abs(wr) > temp) { +/* Computing MIN */ + d__1 = scale, d__2 = temp / abs(wr); + scale = f2cmin(d__1,d__2); + } + s1 = scale * s1; + wr = scale * wr; + +/* Now check for two consecutive small subdiagonals. */ + + i__2 = ifirst + 1; + for (j = ilast - 1; j >= i__2; --j) { + istart = j; + temp = (d__1 = s1 * h__[j + (j - 1) * h_dim1], abs(d__1)); + temp2 = (d__1 = s1 * h__[j + j * h_dim1] - wr * t[j + j * t_dim1], + abs(d__1)); + tempr = f2cmax(temp,temp2); + if (tempr < 1. && tempr != 0.) { + temp /= tempr; + temp2 /= tempr; + } + if ((d__1 = ascale * h__[j + 1 + j * h_dim1] * temp, abs(d__1)) <= + ascale * atol * temp2) { + goto L130; + } +/* L120: */ + } + + istart = ifirst; +L130: + +/* Do an implicit single-shift QZ sweep. */ + +/* Initial Q */ + + temp = s1 * h__[istart + istart * h_dim1] - wr * t[istart + istart * + t_dim1]; + temp2 = s1 * h__[istart + 1 + istart * h_dim1]; + dlartg_(&temp, &temp2, &c__, &s, &tempr); + +/* Sweep */ + + i__2 = ilast - 1; + for (j = istart; j <= i__2; ++j) { + if (j > istart) { + temp = h__[j + (j - 1) * h_dim1]; + dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[ + j + (j - 1) * h_dim1]); + h__[j + 1 + (j - 1) * h_dim1] = 0.; + } + + i__3 = ilastm; + for (jc = j; jc <= i__3; ++jc) { + temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc * + h_dim1]; + h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ * + h__[j + 1 + jc * h_dim1]; + h__[j + jc * h_dim1] = temp; + temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1]; + t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j + + 1 + jc * t_dim1]; + t[j + jc * t_dim1] = temp2; +/* L140: */ + } + if (ilq) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) * + q_dim1]; + q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ * + q[jr + (j + 1) * q_dim1]; + q[jr + j * q_dim1] = temp; +/* L150: */ + } + } + + temp = t[j + 1 + (j + 1) * t_dim1]; + dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + + 1) * t_dim1]); + t[j + 1 + j * t_dim1] = 0.; + +/* Computing MIN */ + i__4 = j + 2; + i__3 = f2cmin(i__4,ilast); + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j * + h_dim1]; + h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ * + h__[jr + j * h_dim1]; + h__[jr + (j + 1) * h_dim1] = temp; +/* L160: */ + } + i__3 = j; + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1] + ; + t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[ + jr + j * t_dim1]; + t[jr + (j + 1) * t_dim1] = temp; +/* L170: */ + } + if (ilz) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j * + z_dim1]; + z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] + + c__ * z__[jr + j * z_dim1]; + z__[jr + (j + 1) * z_dim1] = temp; +/* L180: */ + } + } +/* L190: */ + } + + goto L350; + +/* Use Francis double-shift */ + +/* Note: the Francis double-shift should work with real shifts, */ +/* but only if the block is at least 3x3. */ +/* This code may break if this point is reached with */ +/* a 2x2 block with real eigenvalues. */ + +L200: + if (ifirst + 1 == ilast) { + +/* Special case -- 2x2 block with complex eigenvectors */ + +/* Step 1: Standardize, that is, rotate so that */ + +/* ( B11 0 ) */ +/* B = ( ) with B11 non-negative. */ +/* ( 0 B22 ) */ + + dlasv2_(&t[ilast - 1 + (ilast - 1) * t_dim1], &t[ilast - 1 + + ilast * t_dim1], &t[ilast + ilast * t_dim1], &b22, &b11, & + sr, &cr, &sl, &cl); + + if (b11 < 0.) { + cr = -cr; + sr = -sr; + b11 = -b11; + b22 = -b22; + } + + i__2 = ilastm + 1 - ifirst; + drot_(&i__2, &h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &h__[ + ilast + (ilast - 1) * h_dim1], ldh, &cl, &sl); + i__2 = ilast + 1 - ifrstm; + drot_(&i__2, &h__[ifrstm + (ilast - 1) * h_dim1], &c__1, &h__[ + ifrstm + ilast * h_dim1], &c__1, &cr, &sr); + + if (ilast < ilastm) { + i__2 = ilastm - ilast; + drot_(&i__2, &t[ilast - 1 + (ilast + 1) * t_dim1], ldt, &t[ + ilast + (ilast + 1) * t_dim1], ldt, &cl, &sl); + } + if (ifrstm < ilast - 1) { + i__2 = ifirst - ifrstm; + drot_(&i__2, &t[ifrstm + (ilast - 1) * t_dim1], &c__1, &t[ + ifrstm + ilast * t_dim1], &c__1, &cr, &sr); + } + + if (ilq) { + drot_(n, &q[(ilast - 1) * q_dim1 + 1], &c__1, &q[ilast * + q_dim1 + 1], &c__1, &cl, &sl); + } + if (ilz) { + drot_(n, &z__[(ilast - 1) * z_dim1 + 1], &c__1, &z__[ilast * + z_dim1 + 1], &c__1, &cr, &sr); + } + + t[ilast - 1 + (ilast - 1) * t_dim1] = b11; + t[ilast - 1 + ilast * t_dim1] = 0.; + t[ilast + (ilast - 1) * t_dim1] = 0.; + t[ilast + ilast * t_dim1] = b22; + +/* If B22 is negative, negate column ILAST */ + + if (b22 < 0.) { + i__2 = ilast; + for (j = ifrstm; j <= i__2; ++j) { + h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1]; + t[j + ilast * t_dim1] = -t[j + ilast * t_dim1]; +/* L210: */ + } + + if (ilz) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1]; +/* L220: */ + } + } + b22 = -b22; + } + +/* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.) */ + +/* Recompute shift */ + + d__1 = safmin * 100.; + dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1 + + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &temp, &wr, & + temp2, &wi); + +/* If standardization has perturbed the shift onto real line, */ +/* do another (real single-shift) QR step. */ + + if (wi == 0.) { + goto L350; + } + s1inv = 1. / s1; + +/* Do EISPACK (QZVAL) computation of alpha and beta */ + + a11 = h__[ilast - 1 + (ilast - 1) * h_dim1]; + a21 = h__[ilast + (ilast - 1) * h_dim1]; + a12 = h__[ilast - 1 + ilast * h_dim1]; + a22 = h__[ilast + ilast * h_dim1]; + +/* Compute complex Givens rotation on right */ +/* (Assume some element of C = (sA - wB) > unfl ) */ +/* __ */ +/* (sA - wB) ( CZ -SZ ) */ +/* ( SZ CZ ) */ + + c11r = s1 * a11 - wr * b11; + c11i = -wi * b11; + c12 = s1 * a12; + c21 = s1 * a21; + c22r = s1 * a22 - wr * b22; + c22i = -wi * b22; + + if (abs(c11r) + abs(c11i) + abs(c12) > abs(c21) + abs(c22r) + abs( + c22i)) { + t1 = dlapy3_(&c12, &c11r, &c11i); + cz = c12 / t1; + szr = -c11r / t1; + szi = -c11i / t1; + } else { + cz = dlapy2_(&c22r, &c22i); + if (cz <= safmin) { + cz = 0.; + szr = 1.; + szi = 0.; + } else { + tempr = c22r / cz; + tempi = c22i / cz; + t1 = dlapy2_(&cz, &c21); + cz /= t1; + szr = -c21 * tempr / t1; + szi = c21 * tempi / t1; + } + } + +/* Compute Givens rotation on left */ + +/* ( CQ SQ ) */ +/* ( __ ) A or B */ +/* ( -SQ CQ ) */ + + an = abs(a11) + abs(a12) + abs(a21) + abs(a22); + bn = abs(b11) + abs(b22); + wabs = abs(wr) + abs(wi); + if (s1 * an > wabs * bn) { + cq = cz * b11; + sqr = szr * b22; + sqi = -szi * b22; + } else { + a1r = cz * a11 + szr * a12; + a1i = szi * a12; + a2r = cz * a21 + szr * a22; + a2i = szi * a22; + cq = dlapy2_(&a1r, &a1i); + if (cq <= safmin) { + cq = 0.; + sqr = 1.; + sqi = 0.; + } else { + tempr = a1r / cq; + tempi = a1i / cq; + sqr = tempr * a2r + tempi * a2i; + sqi = tempi * a2r - tempr * a2i; + } + } + t1 = dlapy3_(&cq, &sqr, &sqi); + cq /= t1; + sqr /= t1; + sqi /= t1; + +/* Compute diagonal elements of QBZ */ + + tempr = sqr * szr - sqi * szi; + tempi = sqr * szi + sqi * szr; + b1r = cq * cz * b11 + tempr * b22; + b1i = tempi * b22; + b1a = dlapy2_(&b1r, &b1i); + b2r = cq * cz * b22 + tempr * b11; + b2i = -tempi * b11; + b2a = dlapy2_(&b2r, &b2i); + +/* Normalize so beta > 0, and Im( alpha1 ) > 0 */ + + beta[ilast - 1] = b1a; + beta[ilast] = b2a; + alphar[ilast - 1] = wr * b1a * s1inv; + alphai[ilast - 1] = wi * b1a * s1inv; + alphar[ilast] = wr * b2a * s1inv; + alphai[ilast] = -(wi * b2a) * s1inv; + +/* Step 3: Go to next block -- exit if finished. */ + + ilast = ifirst - 1; + if (ilast < *ilo) { + goto L380; + } + +/* Reset counters */ + + iiter = 0; + eshift = 0.; + if (! ilschr) { + ilastm = ilast; + if (ifrstm > ilast) { + ifrstm = *ilo; + } + } + goto L350; + } else { + +/* Usual case: 3x3 or larger block, using Francis implicit */ +/* double-shift */ + +/* 2 */ +/* Eigenvalue equation is w - c w + d = 0, */ + +/* -1 2 -1 */ +/* so compute 1st column of (A B ) - c A B + d */ +/* using the formula in QZIT (from EISPACK) */ + +/* We assume that the block is at least 3x3 */ + + ad11 = ascale * h__[ilast - 1 + (ilast - 1) * h_dim1] / (bscale * + t[ilast - 1 + (ilast - 1) * t_dim1]); + ad21 = ascale * h__[ilast + (ilast - 1) * h_dim1] / (bscale * t[ + ilast - 1 + (ilast - 1) * t_dim1]); + ad12 = ascale * h__[ilast - 1 + ilast * h_dim1] / (bscale * t[ + ilast + ilast * t_dim1]); + ad22 = ascale * h__[ilast + ilast * h_dim1] / (bscale * t[ilast + + ilast * t_dim1]); + u12 = t[ilast - 1 + ilast * t_dim1] / t[ilast + ilast * t_dim1]; + ad11l = ascale * h__[ifirst + ifirst * h_dim1] / (bscale * t[ + ifirst + ifirst * t_dim1]); + ad21l = ascale * h__[ifirst + 1 + ifirst * h_dim1] / (bscale * t[ + ifirst + ifirst * t_dim1]); + ad12l = ascale * h__[ifirst + (ifirst + 1) * h_dim1] / (bscale * + t[ifirst + 1 + (ifirst + 1) * t_dim1]); + ad22l = ascale * h__[ifirst + 1 + (ifirst + 1) * h_dim1] / ( + bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]); + ad32l = ascale * h__[ifirst + 2 + (ifirst + 1) * h_dim1] / ( + bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]); + u12l = t[ifirst + (ifirst + 1) * t_dim1] / t[ifirst + 1 + (ifirst + + 1) * t_dim1]; + + v[0] = (ad11 - ad11l) * (ad22 - ad11l) - ad12 * ad21 + ad21 * u12 + * ad11l + (ad12l - ad11l * u12l) * ad21l; + v[1] = (ad22l - ad11l - ad21l * u12l - (ad11 - ad11l) - (ad22 - + ad11l) + ad21 * u12) * ad21l; + v[2] = ad32l * ad21l; + + istart = ifirst; + + dlarfg_(&c__3, v, &v[1], &c__1, &tau); + v[0] = 1.; + +/* Sweep */ + + i__2 = ilast - 2; + for (j = istart; j <= i__2; ++j) { + +/* All but last elements: use 3x3 Householder transforms. */ + +/* Zero (j-1)st column of A */ + + if (j > istart) { + v[0] = h__[j + (j - 1) * h_dim1]; + v[1] = h__[j + 1 + (j - 1) * h_dim1]; + v[2] = h__[j + 2 + (j - 1) * h_dim1]; + + dlarfg_(&c__3, &h__[j + (j - 1) * h_dim1], &v[1], &c__1, & + tau); + v[0] = 1.; + h__[j + 1 + (j - 1) * h_dim1] = 0.; + h__[j + 2 + (j - 1) * h_dim1] = 0.; + } + + i__3 = ilastm; + for (jc = j; jc <= i__3; ++jc) { + temp = tau * (h__[j + jc * h_dim1] + v[1] * h__[j + 1 + + jc * h_dim1] + v[2] * h__[j + 2 + jc * h_dim1]); + h__[j + jc * h_dim1] -= temp; + h__[j + 1 + jc * h_dim1] -= temp * v[1]; + h__[j + 2 + jc * h_dim1] -= temp * v[2]; + temp2 = tau * (t[j + jc * t_dim1] + v[1] * t[j + 1 + jc * + t_dim1] + v[2] * t[j + 2 + jc * t_dim1]); + t[j + jc * t_dim1] -= temp2; + t[j + 1 + jc * t_dim1] -= temp2 * v[1]; + t[j + 2 + jc * t_dim1] -= temp2 * v[2]; +/* L230: */ + } + if (ilq) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = tau * (q[jr + j * q_dim1] + v[1] * q[jr + (j + + 1) * q_dim1] + v[2] * q[jr + (j + 2) * q_dim1] + ); + q[jr + j * q_dim1] -= temp; + q[jr + (j + 1) * q_dim1] -= temp * v[1]; + q[jr + (j + 2) * q_dim1] -= temp * v[2]; +/* L240: */ + } + } + +/* Zero j-th column of B (see DLAGBC for details) */ + +/* Swap rows to pivot */ + + ilpivt = FALSE_; +/* Computing MAX */ + d__3 = (d__1 = t[j + 1 + (j + 1) * t_dim1], abs(d__1)), d__4 = + (d__2 = t[j + 1 + (j + 2) * t_dim1], abs(d__2)); + temp = f2cmax(d__3,d__4); +/* Computing MAX */ + d__3 = (d__1 = t[j + 2 + (j + 1) * t_dim1], abs(d__1)), d__4 = + (d__2 = t[j + 2 + (j + 2) * t_dim1], abs(d__2)); + temp2 = f2cmax(d__3,d__4); + if (f2cmax(temp,temp2) < safmin) { + scale = 0.; + u1 = 1.; + u2 = 0.; + goto L250; + } else if (temp >= temp2) { + w11 = t[j + 1 + (j + 1) * t_dim1]; + w21 = t[j + 2 + (j + 1) * t_dim1]; + w12 = t[j + 1 + (j + 2) * t_dim1]; + w22 = t[j + 2 + (j + 2) * t_dim1]; + u1 = t[j + 1 + j * t_dim1]; + u2 = t[j + 2 + j * t_dim1]; + } else { + w21 = t[j + 1 + (j + 1) * t_dim1]; + w11 = t[j + 2 + (j + 1) * t_dim1]; + w22 = t[j + 1 + (j + 2) * t_dim1]; + w12 = t[j + 2 + (j + 2) * t_dim1]; + u2 = t[j + 1 + j * t_dim1]; + u1 = t[j + 2 + j * t_dim1]; + } + +/* Swap columns if nec. */ + + if (abs(w12) > abs(w11)) { + ilpivt = TRUE_; + temp = w12; + temp2 = w22; + w12 = w11; + w22 = w21; + w11 = temp; + w21 = temp2; + } + +/* LU-factor */ + + temp = w21 / w11; + u2 -= temp * u1; + w22 -= temp * w12; + w21 = 0.; + +/* Compute SCALE */ + + scale = 1.; + if (abs(w22) < safmin) { + scale = 0.; + u2 = 1.; + u1 = -w12 / w11; + goto L250; + } + if (abs(w22) < abs(u2)) { + scale = (d__1 = w22 / u2, abs(d__1)); + } + if (abs(w11) < abs(u1)) { +/* Computing MIN */ + d__2 = scale, d__3 = (d__1 = w11 / u1, abs(d__1)); + scale = f2cmin(d__2,d__3); + } + +/* Solve */ + + u2 = scale * u2 / w22; + u1 = (scale * u1 - w12 * u2) / w11; + +L250: + if (ilpivt) { + temp = u2; + u2 = u1; + u1 = temp; + } + +/* Compute Householder Vector */ + +/* Computing 2nd power */ + d__1 = scale; +/* Computing 2nd power */ + d__2 = u1; +/* Computing 2nd power */ + d__3 = u2; + t1 = sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); + tau = scale / t1 + 1.; + vs = -1. / (scale + t1); + v[0] = 1.; + v[1] = vs * u1; + v[2] = vs * u2; + +/* Apply transformations from the right. */ + +/* Computing MIN */ + i__4 = j + 3; + i__3 = f2cmin(i__4,ilast); + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = tau * (h__[jr + j * h_dim1] + v[1] * h__[jr + (j + + 1) * h_dim1] + v[2] * h__[jr + (j + 2) * h_dim1]); + h__[jr + j * h_dim1] -= temp; + h__[jr + (j + 1) * h_dim1] -= temp * v[1]; + h__[jr + (j + 2) * h_dim1] -= temp * v[2]; +/* L260: */ + } + i__3 = j + 2; + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = tau * (t[jr + j * t_dim1] + v[1] * t[jr + (j + 1) * + t_dim1] + v[2] * t[jr + (j + 2) * t_dim1]); + t[jr + j * t_dim1] -= temp; + t[jr + (j + 1) * t_dim1] -= temp * v[1]; + t[jr + (j + 2) * t_dim1] -= temp * v[2]; +/* L270: */ + } + if (ilz) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = tau * (z__[jr + j * z_dim1] + v[1] * z__[jr + ( + j + 1) * z_dim1] + v[2] * z__[jr + (j + 2) * + z_dim1]); + z__[jr + j * z_dim1] -= temp; + z__[jr + (j + 1) * z_dim1] -= temp * v[1]; + z__[jr + (j + 2) * z_dim1] -= temp * v[2]; +/* L280: */ + } + } + t[j + 1 + j * t_dim1] = 0.; + t[j + 2 + j * t_dim1] = 0.; +/* L290: */ + } + +/* Last elements: Use Givens rotations */ + +/* Rotations from the left */ + + j = ilast - 1; + temp = h__[j + (j - 1) * h_dim1]; + dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[j + + (j - 1) * h_dim1]); + h__[j + 1 + (j - 1) * h_dim1] = 0.; + + i__2 = ilastm; + for (jc = j; jc <= i__2; ++jc) { + temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc * + h_dim1]; + h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ * + h__[j + 1 + jc * h_dim1]; + h__[j + jc * h_dim1] = temp; + temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1]; + t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j + + 1 + jc * t_dim1]; + t[j + jc * t_dim1] = temp2; +/* L300: */ + } + if (ilq) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) * + q_dim1]; + q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ * + q[jr + (j + 1) * q_dim1]; + q[jr + j * q_dim1] = temp; +/* L310: */ + } + } + +/* Rotations from the right. */ + + temp = t[j + 1 + (j + 1) * t_dim1]; + dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + + 1) * t_dim1]); + t[j + 1 + j * t_dim1] = 0.; + + i__2 = ilast; + for (jr = ifrstm; jr <= i__2; ++jr) { + temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j * + h_dim1]; + h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ * + h__[jr + j * h_dim1]; + h__[jr + (j + 1) * h_dim1] = temp; +/* L320: */ + } + i__2 = ilast - 1; + for (jr = ifrstm; jr <= i__2; ++jr) { + temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1] + ; + t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[ + jr + j * t_dim1]; + t[jr + (j + 1) * t_dim1] = temp; +/* L330: */ + } + if (ilz) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j * + z_dim1]; + z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] + + c__ * z__[jr + j * z_dim1]; + z__[jr + (j + 1) * z_dim1] = temp; +/* L340: */ + } + } + +/* End of Double-Shift code */ + + } + + goto L350; + +/* End of iteration loop */ + +L350: +/* L360: */ + ; + } + +/* Drop-through = non-convergence */ + + *info = ilast; + goto L420; + +/* Successful completion of all QZ steps */ + +L380: + +/* Set Eigenvalues 1:ILO-1 */ + + i__1 = *ilo - 1; + for (j = 1; j <= i__1; ++j) { + if (t[j + j * t_dim1] < 0.) { + if (ilschr) { + i__2 = j; + for (jr = 1; jr <= i__2; ++jr) { + h__[jr + j * h_dim1] = -h__[jr + j * h_dim1]; + t[jr + j * t_dim1] = -t[jr + j * t_dim1]; +/* L390: */ + } + } else { + h__[j + j * h_dim1] = -h__[j + j * h_dim1]; + t[j + j * t_dim1] = -t[j + j * t_dim1]; + } + if (ilz) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + z__[jr + j * z_dim1] = -z__[jr + j * z_dim1]; +/* L400: */ + } + } + } + alphar[j] = h__[j + j * h_dim1]; + alphai[j] = 0.; + beta[j] = t[j + j * t_dim1]; +/* L410: */ + } + +/* Normal Termination */ + + *info = 0; + +/* Exit (other than argument error) -- return optimal workspace size */ + +L420: + work[1] = (doublereal) (*n); + return 0; + +/* End of DHGEQZ */ + +} /* dhgeqz_ */ + diff --git a/lapack-netlib/SRC/dhsein.c b/lapack-netlib/SRC/dhsein.c new file mode 100644 index 000000000..3e310d4f9 --- /dev/null +++ b/lapack-netlib/SRC/dhsein.c @@ -0,0 +1,972 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DHSEIN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DHSEIN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, */ +/* VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, */ +/* IFAILR, INFO ) */ + +/* CHARACTER EIGSRC, INITV, SIDE */ +/* INTEGER INFO, LDH, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IFAILL( * ), IFAILR( * ) */ +/* DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WI( * ), WORK( * ), WR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DHSEIN uses inverse iteration to find specified right and/or left */ +/* > eigenvectors of a real upper Hessenberg matrix H. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of the matrix H */ +/* > corresponding to an eigenvalue w are defined by: */ +/* > */ +/* > H * x = w * x, y**h * H = w * y**h */ +/* > */ +/* > where y**h denotes the conjugate transpose of the vector y. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EIGSRC */ +/* > \verbatim */ +/* > EIGSRC is CHARACTER*1 */ +/* > Specifies the source of eigenvalues supplied in (WR,WI): */ +/* > = 'Q': the eigenvalues were found using DHSEQR; thus, if */ +/* > H has zero subdiagonal elements, and so is */ +/* > block-triangular, then the j-th eigenvalue can be */ +/* > assumed to be an eigenvalue of the block containing */ +/* > the j-th row/column. This property allows DHSEIN to */ +/* > perform inverse iteration on just one diagonal block. */ +/* > = 'N': no assumptions are made on the correspondence */ +/* > between eigenvalues and diagonal blocks. In this */ +/* > case, DHSEIN must always perform inverse iteration */ +/* > using the whole matrix H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INITV */ +/* > \verbatim */ +/* > INITV is CHARACTER*1 */ +/* > = 'N': no initial vectors are supplied; */ +/* > = 'U': user-supplied initial vectors are stored in the arrays */ +/* > VL and/or VR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > Specifies the eigenvectors to be computed. To select the */ +/* > real eigenvector corresponding to a real eigenvalue WR(j), */ +/* > SELECT(j) must be set to .TRUE.. To select the complex */ +/* > eigenvector corresponding to a complex eigenvalue */ +/* > (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), */ +/* > either SELECT(j) or SELECT(j+1) or both must be set to */ +/* > .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is */ +/* > .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is DOUBLE PRECISION array, dimension (LDH,N) */ +/* > The upper Hessenberg matrix H. */ +/* > If a NaN is detected in H, the routine will return with INFO=-6. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WR */ +/* > \verbatim */ +/* > WR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WI */ +/* > \verbatim */ +/* > WI is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > On entry, the real and imaginary parts of the eigenvalues of */ +/* > H; a complex conjugate pair of eigenvalues must be stored in */ +/* > consecutive elements of WR and WI. */ +/* > On exit, WR may have been altered since close eigenvalues */ +/* > are perturbed slightly in searching for independent */ +/* > eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,MM) */ +/* > On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */ +/* > contain starting vectors for the inverse iteration for the */ +/* > left eigenvectors; the starting vector for each eigenvector */ +/* > must be in the same column(s) in which the eigenvector will */ +/* > be stored. */ +/* > On exit, if SIDE = 'L' or 'B', the left eigenvectors */ +/* > specified by SELECT will be stored consecutively in the */ +/* > columns of VL, in the same order as their eigenvalues. A */ +/* > complex eigenvector corresponding to a complex eigenvalue is */ +/* > stored in two consecutive columns, the first holding the real */ +/* > part and the second the imaginary part. */ +/* > If SIDE = 'R', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= f2cmax(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,MM) */ +/* > On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */ +/* > contain starting vectors for the inverse iteration for the */ +/* > right eigenvectors; the starting vector for each eigenvector */ +/* > must be in the same column(s) in which the eigenvector will */ +/* > be stored. */ +/* > On exit, if SIDE = 'R' or 'B', the right eigenvectors */ +/* > specified by SELECT will be stored consecutively in the */ +/* > columns of VR, in the same order as their eigenvalues. A */ +/* > complex eigenvector corresponding to a complex eigenvalue is */ +/* > stored in two consecutive columns, the first holding the real */ +/* > part and the second the imaginary part. */ +/* > If SIDE = 'L', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= f2cmax(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR required to */ +/* > store the eigenvectors; each selected real eigenvector */ +/* > occupies one column and each selected complex eigenvector */ +/* > occupies two columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension ((N+2)*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAILL */ +/* > \verbatim */ +/* > IFAILL is INTEGER array, dimension (MM) */ +/* > If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */ +/* > eigenvector in the i-th column of VL (corresponding to the */ +/* > eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */ +/* > eigenvector converged satisfactorily. If the i-th and (i+1)th */ +/* > columns of VL hold a complex eigenvector, then IFAILL(i) and */ +/* > IFAILL(i+1) are set to the same value. */ +/* > If SIDE = 'R', IFAILL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAILR */ +/* > \verbatim */ +/* > IFAILR is INTEGER array, dimension (MM) */ +/* > If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */ +/* > eigenvector in the i-th column of VR (corresponding to the */ +/* > eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */ +/* > eigenvector converged satisfactorily. If the i-th and (i+1)th */ +/* > columns of VR hold a complex eigenvector, then IFAILR(i) and */ +/* > IFAILR(i+1) are set to the same value. */ +/* > If SIDE = 'L', IFAILR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, i is the number of eigenvectors which */ +/* > failed to converge; see IFAILL and IFAILR for further */ +/* > details. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Each eigenvector is normalized so that the element of largest */ +/* > magnitude has magnitude 1; here the magnitude of a complex number */ +/* > (x,y) is taken to be |x|+|y|. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dhsein_(char *side, char *eigsrc, char *initv, logical * + select, integer *n, doublereal *h__, integer *ldh, doublereal *wr, + doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, + integer *ldvr, integer *mm, integer *m, doublereal *work, integer * + ifaill, integer *ifailr, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2; + doublereal d__1, d__2; + + /* Local variables */ + logical pair; + doublereal unfl; + integer i__, k; + extern logical lsame_(char *, char *); + integer iinfo; + logical leftv, bothv; + doublereal hnorm; + integer kl; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int dlaein_(logical *, logical *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal * + , doublereal *, doublereal *, integer *); + integer kr; + extern doublereal dlanhs_(char *, integer *, doublereal *, integer *, + doublereal *); + extern logical disnan_(doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + logical noinit; + integer ldwork; + logical rightv, fromqr; + doublereal smlnum; + integer kln, ksi; + doublereal wki; + integer ksr; + doublereal ulp, wkr, eps3; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters. */ + + /* Parameter adjustments */ + --select; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --wr; + --wi; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --ifaill; + --ifailr; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + fromqr = lsame_(eigsrc, "Q"); + + noinit = lsame_(initv, "N"); + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors, and standardize the array SELECT. */ + + *m = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + select[k] = FALSE_; + } else { + if (wi[k] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + select[k] = TRUE_; + *m += 2; + } + } + } +/* L10: */ + } + + *info = 0; + if (! rightv && ! leftv) { + *info = -1; + } else if (! fromqr && ! lsame_(eigsrc, "N")) { + *info = -2; + } else if (! noinit && ! lsame_(initv, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -5; + } else if (*ldh < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -11; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -13; + } else if (*mm < *m) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DHSEIN", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Set machine-dependent constants. */ + + unfl = dlamch_("Safe minimum"); + ulp = dlamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1. - ulp) / smlnum; + + ldwork = *n + 1; + + kl = 1; + kln = 0; + if (fromqr) { + kr = 0; + } else { + kr = *n; + } + ksr = 1; + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (select[k]) { + +/* Compute eigenvector(s) corresponding to W(K). */ + + if (fromqr) { + +/* If affiliation of eigenvalues is known, check whether */ +/* the matrix splits. */ + +/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */ +/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */ +/* KR = N). */ + +/* Then inverse iteration can be performed with the */ +/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */ +/* the submatrix H(1:KR,1:KR) for a right eigenvector. */ + + i__2 = kl + 1; + for (i__ = k; i__ >= i__2; --i__) { + if (h__[i__ + (i__ - 1) * h_dim1] == 0.) { + goto L30; + } +/* L20: */ + } +L30: + kl = i__; + if (k > kr) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + if (h__[i__ + 1 + i__ * h_dim1] == 0.) { + goto L50; + } +/* L40: */ + } +L50: + kr = i__; + } + } + + if (kl != kln) { + kln = kl; + +/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */ +/* has not ben computed before. */ + + i__2 = kr - kl + 1; + hnorm = dlanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, & + work[1]); + if (disnan_(&hnorm)) { + *info = -6; + return 0; + } else if (hnorm > 0.) { + eps3 = hnorm * ulp; + } else { + eps3 = smlnum; + } + } + +/* Perturb eigenvalue if it is close to any previous */ +/* selected eigenvalues affiliated to the submatrix */ +/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */ + + wkr = wr[k]; + wki = wi[k]; +L60: + i__2 = kl; + for (i__ = k - 1; i__ >= i__2; --i__) { + if (select[i__] && (d__1 = wr[i__] - wkr, abs(d__1)) + (d__2 = + wi[i__] - wki, abs(d__2)) < eps3) { + wkr += eps3; + goto L60; + } +/* L70: */ + } + wr[k] = wkr; + + pair = wki != 0.; + if (pair) { + ksi = ksr + 1; + } else { + ksi = ksr; + } + if (leftv) { + +/* Compute left eigenvector. */ + + i__2 = *n - kl + 1; + dlaein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh, + &wkr, &wki, &vl[kl + ksr * vl_dim1], &vl[kl + ksi * + vl_dim1], &work[1], &ldwork, &work[*n * *n + *n + 1], + &eps3, &smlnum, &bignum, &iinfo); + if (iinfo > 0) { + if (pair) { + *info += 2; + } else { + ++(*info); + } + ifaill[ksr] = k; + ifaill[ksi] = k; + } else { + ifaill[ksr] = 0; + ifaill[ksi] = 0; + } + i__2 = kl - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + vl[i__ + ksr * vl_dim1] = 0.; +/* L80: */ + } + if (pair) { + i__2 = kl - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + vl[i__ + ksi * vl_dim1] = 0.; +/* L90: */ + } + } + } + if (rightv) { + +/* Compute right eigenvector. */ + + dlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, & + wki, &vr[ksr * vr_dim1 + 1], &vr[ksi * vr_dim1 + 1], & + work[1], &ldwork, &work[*n * *n + *n + 1], &eps3, & + smlnum, &bignum, &iinfo); + if (iinfo > 0) { + if (pair) { + *info += 2; + } else { + ++(*info); + } + ifailr[ksr] = k; + ifailr[ksi] = k; + } else { + ifailr[ksr] = 0; + ifailr[ksi] = 0; + } + i__2 = *n; + for (i__ = kr + 1; i__ <= i__2; ++i__) { + vr[i__ + ksr * vr_dim1] = 0.; +/* L100: */ + } + if (pair) { + i__2 = *n; + for (i__ = kr + 1; i__ <= i__2; ++i__) { + vr[i__ + ksi * vr_dim1] = 0.; +/* L110: */ + } + } + } + + if (pair) { + ksr += 2; + } else { + ++ksr; + } + } +/* L120: */ + } + + return 0; + +/* End of DHSEIN */ + +} /* dhsein_ */ + diff --git a/lapack-netlib/SRC/dhseqr.c b/lapack-netlib/SRC/dhseqr.c new file mode 100644 index 000000000..cae1e7f71 --- /dev/null +++ b/lapack-netlib/SRC/dhseqr.c @@ -0,0 +1,945 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DHSEQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DHSEQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, */ +/* LDZ, WORK, LWORK, INFO ) */ + +/* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N */ +/* CHARACTER COMPZ, JOB */ +/* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DHSEQR computes the eigenvalues of a Hessenberg matrix H */ +/* > and, optionally, the matrices T and Z from the Schur decomposition */ +/* > H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ +/* > Schur form), and Z is the orthogonal matrix of Schur vectors. */ +/* > */ +/* > Optionally Z may be postmultiplied into an input orthogonal */ +/* > matrix Q so that this routine can give the Schur factorization */ +/* > of a matrix A which has been reduced to the Hessenberg form H */ +/* > by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > = 'E': compute eigenvalues only; */ +/* > = 'S': compute eigenvalues and the Schur form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': no Schur vectors are computed; */ +/* > = 'I': Z is initialized to the unit matrix and the matrix Z */ +/* > of Schur vectors of H is returned; */ +/* > = 'V': Z must contain an orthogonal matrix Q on entry, and */ +/* > the product Q*Z is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > It is assumed that H is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ +/* > set by a previous call to DGEBAL, and then passed to ZGEHRD */ +/* > when the matrix output by DGEBAL is reduced to Hessenberg */ +/* > form. Otherwise ILO and IHI should be set to 1 and N */ +/* > respectively. If N > 0, then 1 <= ILO <= IHI <= N. */ +/* > If N = 0, then ILO = 1 and IHI = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is DOUBLE PRECISION array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO = 0 and JOB = 'S', then H contains the */ +/* > upper quasi-triangular matrix T from the Schur decomposition */ +/* > (the Schur form); 2-by-2 diagonal blocks (corresponding to */ +/* > complex conjugate pairs of eigenvalues) are returned in */ +/* > standard form, with H(i,i) = H(i+1,i+1) and */ +/* > H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and JOB = 'E', the */ +/* > contents of H are unspecified on exit. (The output value of */ +/* > H when INFO > 0 is given under the description of INFO */ +/* > below.) */ +/* > */ +/* > Unlike earlier versions of DHSEQR, this subroutine may */ +/* > explicitly H(i,j) = 0 for i > j and j = 1, 2, ... ILO-1 */ +/* > or j = IHI+1, IHI+2, ... N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR */ +/* > \verbatim */ +/* > WR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > The real and imaginary parts, respectively, of the computed */ +/* > eigenvalues. 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 JOB = 'S', 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,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ,N) */ +/* > If COMPZ = 'N', Z is not referenced. */ +/* > If COMPZ = 'I', on entry Z need not be set and on exit, */ +/* > if INFO = 0, Z contains the orthogonal matrix Z of the Schur */ +/* > vectors of H. If COMPZ = 'V', on entry Z must contain an */ +/* > N-by-N matrix Q, which is assumed to be equal to the unit */ +/* > matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */ +/* > if INFO = 0, Z contains Q*Z. */ +/* > Normally Q is the orthogonal matrix generated by DORGHR */ +/* > after the call to DGEHRD which formed the Hessenberg matrix */ +/* > H. (The output value of Z when INFO > 0 is given under */ +/* > the description of INFO below.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. if COMPZ = 'I' or */ +/* > COMPZ = 'V', then LDZ >= MAX(1,N). Otherwise, LDZ >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns an estimate of */ +/* > the optimal value for LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N) */ +/* > is sufficient and delivers very good and sometimes */ +/* > optimal performance. However, LWORK as large as 11*N */ +/* > may be required for optimal performance. A workspace */ +/* > query is recommended to determine the optimal workspace */ +/* > size. */ +/* > */ +/* > If LWORK = -1, then DHSEQR does a workspace query. */ +/* > In this case, DHSEQR checks the input parameters and */ +/* > estimates the optimal workspace size for the given */ +/* > values of N, ILO and IHI. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is */ +/* > issued by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal */ +/* > value */ +/* > > 0: if INFO = i, DHSEQR failed to compute all of */ +/* > the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* > and WI contain those eigenvalues which have been */ +/* > successfully computed. (Failures are rare.) */ +/* > */ +/* > If INFO > 0 and JOB = 'E', then on exit, the */ +/* > remaining unconverged eigenvalues are the eigen- */ +/* > values of the upper Hessenberg matrix rows and */ +/* > columns ILO through INFO of the final, output */ +/* > value of H. */ +/* > */ +/* > If INFO > 0 and JOB = 'S', then on exit */ +/* > */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > */ +/* > where U is an orthogonal matrix. The final */ +/* > value of H is upper Hessenberg and quasi-triangular */ +/* > in rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and COMPZ = 'V', then on exit */ +/* > */ +/* > (final value of Z) = (initial value of Z)*U */ +/* > */ +/* > where U is the orthogonal matrix in (*) (regard- */ +/* > less of the value of JOB.) */ +/* > */ +/* > If INFO > 0 and COMPZ = 'I', then on exit */ +/* > (final value of Z) = U */ +/* > where U is the orthogonal matrix in (*) (regard- */ +/* > less of the value of JOB.) */ +/* > */ +/* > If INFO > 0 and COMPZ = 'N', then Z is not */ +/* > accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Default values supplied by */ +/* > ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */ +/* > It is suggested that these defaults be adjusted in order */ +/* > to attain best performance in each particular */ +/* > computational environment. */ +/* > */ +/* > ISPEC=12: The DLAHQR vs DLAQR0 crossover point. */ +/* > Default: 75. (Must be at least 11.) */ +/* > */ +/* > ISPEC=13: Recommended deflation window size. */ +/* > This depends on ILO, IHI and NS. NS is the */ +/* > number of simultaneous shifts returned */ +/* > by ILAENV(ISPEC=15). (See ISPEC=15 below.) */ +/* > The default for (IHI-ILO+1) <= 500 is NS. */ +/* > The default for (IHI-ILO+1) > 500 is 3*NS/2. */ +/* > */ +/* > ISPEC=14: Nibble crossover point. (See IPARMQ for */ +/* > details.) Default: 14% of deflation window */ +/* > size. */ +/* > */ +/* > ISPEC=15: Number of simultaneous shifts in a multishift */ +/* > QR iteration. */ +/* > */ +/* > If IHI-ILO+1 is ... */ +/* > */ +/* > greater than ...but less ... the */ +/* > or equal to ... than default is */ +/* > */ +/* > 1 30 NS = 2(+) */ +/* > 30 60 NS = 4(+) */ +/* > 60 150 NS = 10(+) */ +/* > 150 590 NS = ** */ +/* > 590 3000 NS = 64 */ +/* > 3000 6000 NS = 128 */ +/* > 6000 infinity NS = 256 */ +/* > */ +/* > (+) By default some or all matrices of this order */ +/* > are passed to the implicit double shift routine */ +/* > DLAHQR and this parameter is ignored. See */ +/* > ISPEC=12 above and comments in IPARMQ for */ +/* > details. */ +/* > */ +/* > (**) The asterisks (**) indicate an ad-hoc */ +/* > function of N increasing from 10 to 64. */ +/* > */ +/* > ISPEC=16: Select structured matrix multiply. */ +/* > If the number of simultaneous shifts (specified */ +/* > by ISPEC=15) is less than 14, then the default */ +/* > for ISPEC=16 is 0. Otherwise the default for */ +/* > ISPEC=16 is 2. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > \n */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* > of Matrix Analysis, volume 23, pages 948--973, 2002. */ + +/* ===================================================================== */ +/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo, + integer *ihi, doublereal *h__, integer *ldh, doublereal *wr, + doublereal *wi, doublereal *z__, integer *ldz, doublereal *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3; + doublereal d__1; + char ch__1[2]; + + /* Local variables */ + integer kbot, nmin, i__; + extern logical lsame_(char *, char *); + logical initz; + doublereal workl[49]; + logical wantt, wantz; + extern /* Subroutine */ int dlaqr0_(logical *, logical *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *); + doublereal hl[2401] /* was [49][49] */; + extern /* Subroutine */ int dlahqr_(logical *, logical *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *), dlacpy_(char *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *), dlaset_(char *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . DLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== NL allocates some local workspace to help small matrices */ +/* . through a rare DLAHQR failure. NL > NTINY = 15 is */ +/* . required and NL <= NMIN = ILAENV(ISPEC=12,...) is recom- */ +/* . mended. (The default value of NMIN is 75.) Using NL = 49 */ +/* . allows up to six simultaneous shifts and a 16-by-16 */ +/* . deflation window. ==== */ + +/* ==== Decode and check the input parameters. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantt = lsame_(job, "S"); + initz = lsame_(compz, "I"); + wantz = initz || lsame_(compz, "V"); + work[1] = (doublereal) f2cmax(1,*n); + lquery = *lwork == -1; + + *info = 0; + if (! lsame_(job, "E") && ! wantt) { + *info = -1; + } else if (! lsame_(compz, "N") && ! wantz) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1 || *ilo > f2cmax(1,*n)) { + *info = -4; + } else if (*ihi < f2cmin(*ilo,*n) || *ihi > *n) { + *info = -5; + } else if (*ldh < f2cmax(1,*n)) { + *info = -7; + } else if (*ldz < 1 || wantz && *ldz < f2cmax(1,*n)) { + *info = -11; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -13; + } + + if (*info != 0) { + +/* ==== Quick return in case of invalid argument. ==== */ + + i__1 = -(*info); + xerbla_("DHSEQR", &i__1, (ftnlen)6); + return 0; + + } else if (*n == 0) { + +/* ==== Quick return in case N = 0; nothing to do. ==== */ + + return 0; + + } else if (lquery) { + +/* ==== Quick return in case of a workspace query ==== */ + + dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[ + 1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); +/* ==== Ensure reported workspace size is backward-compatible with */ +/* . previous LAPACK versions. ==== */ +/* Computing MAX */ + d__1 = (doublereal) f2cmax(1,*n); + work[1] = f2cmax(d__1,work[1]); + return 0; + + } else { + +/* ==== copy eigenvalues isolated by DGEBAL ==== */ + + i__1 = *ilo - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + wr[i__] = h__[i__ + i__ * h_dim1]; + wi[i__] = 0.; +/* L10: */ + } + i__1 = *n; + for (i__ = *ihi + 1; i__ <= i__1; ++i__) { + wr[i__] = h__[i__ + i__ * h_dim1]; + wi[i__] = 0.; +/* L20: */ + } + +/* ==== Initialize Z, if requested ==== */ + + if (initz) { + dlaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz) + ; + } + +/* ==== Quick return if possible ==== */ + + if (*ilo == *ihi) { + wr[*ilo] = h__[*ilo + *ilo * h_dim1]; + wi[*ilo] = 0.; + return 0; + } + +/* ==== DLAHQR/DLAQR0 crossover point ==== */ + +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = job; + i__2[1] = 1, a__1[1] = compz; + s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); + nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); + nmin = f2cmax(15,nmin); + +/* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== */ + + if (*n > nmin) { + dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], + &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, + info); + } else { + +/* ==== Small matrix ==== */ + + dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], + &wi[1], ilo, ihi, &z__[z_offset], ldz, info); + + if (*info > 0) { + +/* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds */ +/* . when DLAHQR fails. ==== */ + + kbot = *info; + + if (*n >= 49) { + +/* ==== Larger matrices have enough subdiagonal scratch */ +/* . space to call DLAQR0 directly. ==== */ + + dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], + ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], + ldz, &work[1], lwork, info); + + } else { + +/* ==== Tiny matrices don't have enough subdiagonal */ +/* . scratch space to benefit from DLAQR0. Hence, */ +/* . tiny matrices must be copied into a larger */ +/* . array before calling DLAQR0. ==== */ + + dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); + hl[*n + 1 + *n * 49 - 50] = 0.; + i__1 = 49 - *n; + dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * + 49 - 49], &c__49); + dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & + wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, + workl, &c__49, info); + if (wantt || *info != 0) { + dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); + } + } + } + } + +/* ==== Clear out the trash, if necessary. ==== */ + + if ((wantt || *info != 0) && *n > 2) { + i__1 = *n - 2; + i__3 = *n - 2; + dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh); + } + +/* ==== Ensure reported workspace size is backward-compatible with */ +/* . previous LAPACK versions. ==== */ + +/* Computing MAX */ + d__1 = (doublereal) f2cmax(1,*n); + work[1] = f2cmax(d__1,work[1]); + } + +/* ==== End of DHSEQR ==== */ + + return 0; +} /* dhseqr_ */ + diff --git a/lapack-netlib/SRC/disnan.c b/lapack-netlib/SRC/disnan.c new file mode 100644 index 000000000..b34536c9a --- /dev/null +++ b/lapack-netlib/SRC/disnan.c @@ -0,0 +1,469 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DISNAN tests input for NaN. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DISNAN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* LOGICAL FUNCTION DISNAN( DIN ) */ + +/* DOUBLE PRECISION DIN */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DISNAN returns .TRUE. if its argument is NaN, and .FALSE. */ +/* > otherwise. To be replaced by the Fortran 2003 intrinsic in the */ +/* > future. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] DIN */ +/* > \verbatim */ +/* > DIN is DOUBLE PRECISION */ +/* > Input to test for NaN. */ +/* > \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 disnan_(doublereal *din) +{ + /* System generated locals */ + logical ret_val; + + /* Local variables */ + extern logical dlaisnan_(doublereal *, doublereal *); + + +/* -- 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 = dlaisnan_(din, din); + return ret_val; +} /* disnan_ */ + diff --git a/lapack-netlib/SRC/dla_gbamv.c b/lapack-netlib/SRC/dla_gbamv.c new file mode 100644 index 000000000..6c72b4be9 --- /dev/null +++ b/lapack-netlib/SRC/dla_gbamv.c @@ -0,0 +1,818 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GBAMV performs a matrix-vector operation to calculate error bounds. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GBAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, */ +/* INCX, BETA, Y, INCY ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS */ +/* DOUBLE PRECISION AB( LDAB, * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_GBAMV performs one of the matrix-vector operations */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > or y := alpha*abs(A)**T*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > m by n matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is INTEGER */ +/* > On entry, TRANS specifies the operation to be performed as */ +/* > follows: */ +/* > */ +/* > BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */ +/* > BLAS_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > BLAS_CONJ_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of the matrix A. */ +/* > M must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension ( LDAB, n ) */ +/* > Before entry, the leading m by n part of the array AB must */ +/* > contain the matrix of coefficients. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > On entry, LDA specifies the first dimension of AB as declared */ +/* > in the calling (sub) program. LDAB must be at least */ +/* > f2cmax( 1, m ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* > Before entry, the incremented array X must contain the */ +/* > vector x. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > On entry, INCX specifies the increment for the elements of */ +/* > X. INCX must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > */ +/* > Level 2 Blas routine. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_gbamv_(integer *trans, integer *m, integer *n, + integer *kl, integer *ku, doublereal *alpha, doublereal *ab, integer * + ldab, doublereal *x, integer *incx, doublereal *beta, doublereal *y, + integer *incy) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + + /* Local variables */ + integer info; + doublereal temp; + integer lenx, leny; + extern integer ilatrans_(char *); + doublereal safe1; + integer i__, j; + logical symb_zero__; + integer kd, ke; + extern doublereal dlamch_(char *); + integer iy, jx, kx, ky; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*kl < 0 || *kl > *m - 1) { + info = 4; + } else if (*ku < 0 || *ku > *n - 1) { + info = 5; + } else if (*ldab < *kl + *ku + 1) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("DLA_GBAMV ", &info, (ftnlen)10); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (*trans == ilatrans_("N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = dlamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + kd = *ku + 1; + ke = *kl + 1; + iy = ky; + if (*incx == 1) { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,lenx); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + temp = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs( + d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,lenx); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + temp = (d__1 = ab[ke - i__ + j + i__ * ab_dim1], abs( + d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,lenx); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + temp = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs( + d__1)); + symb_zero__ = symb_zero__ && (x[jx] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,lenx); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + temp = (d__1 = ab[ke - i__ + j + i__ * ab_dim1], abs( + d__1)); + symb_zero__ = symb_zero__ && (x[jx] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of DLA_GBAMV */ + +} /* dla_gbamv__ */ + diff --git a/lapack-netlib/SRC/dla_gbrcond.c b/lapack-netlib/SRC/dla_gbrcond.c new file mode 100644 index 000000000..00fe7bdb9 --- /dev/null +++ b/lapack-netlib/SRC/dla_gbrcond.c @@ -0,0 +1,791 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GBRCOND estimates the Skeel condition number for a general banded matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GBRCOND + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, */ +/* AFB, LDAFB, IPIV, CMODE, C, */ +/* INFO, WORK, IWORK ) */ + +/* CHARACTER TRANS */ +/* INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE */ +/* INTEGER IWORK( * ), IPIV( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), */ +/* $ C( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_GBRCOND 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] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(KU+1+i-j,j) = A(i,j) for f2cmax(1,j-KU)<=i<=f2cmin(N,j+kl) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by DGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by DGBTRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (5*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 doubleGBcomputational */ + +/* ===================================================================== */ +doublereal dla_gbrcond_(char *trans, integer *n, integer *kl, integer *ku, + doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, + integer *ipiv, integer *cmode, doublereal *c__, integer *info, + doublereal *work, integer *iwork) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer kd, ke; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dgbtrs_( + char *, integer *, integer *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *); + doublereal ainvnm, tmp; + logical notrans; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + notrans = lsame_(trans, "N"); + if (! notrans && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *n - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLA_GBRCOND", &i__1, (ftnlen)11); + return ret_val; + } + if (*n == 0) { + ret_val = 1.; + return ret_val; + } + +/* Compute the equilibration matrix R such that */ +/* inv(R)*A*C has unit 1-norm. */ + + kd = *ku + 1; + ke = *kl + 1; + if (notrans) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,*n); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] * c__[j], + abs(d__1)); + } + } else if (*cmode == 0) { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,*n); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1)); + } + } else { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,*n); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] / c__[j], + abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,*n); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] * c__[j], + abs(d__1)); + } + } else if (*cmode == 0) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,*n); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1], abs(d__1) + ); + } + } else { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,*n); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] / c__[j], + abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + kase = 0; +L10: + dlacn2_(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 (notrans) { + dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } else { + dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &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 (notrans) { + dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } else { + dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* dla_gbrcond__ */ + diff --git a/lapack-netlib/SRC/dla_gbrfsx_extended.c b/lapack-netlib/SRC/dla_gbrfsx_extended.c new file mode 100644 index 000000000..2e06d9796 --- /dev/null +++ b/lapack-netlib/SRC/dla_gbrfsx_extended.c @@ -0,0 +1,1143 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GBRFSX_EXTENDED improves the computed solution to a system of linear equations for general +banded matrices by performing extra-precise iterative refinement and provides error bounds and backwar +d error estimates for the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GBRFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, */ +/* NRHS, AB, LDAB, AFB, LDAFB, IPIV, */ +/* COLEQU, C, B, LDB, Y, LDY, */ +/* BERR_OUT, N_NORMS, ERR_BNDS_NORM, */ +/* ERR_BNDS_COMP, RES, AYB, DY, */ +/* Y_TAIL, RCOND, ITHRESH, RTHRESH, */ +/* DZ_UB, IGNORE_CWISE, INFO ) */ + +/* INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, */ +/* $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES(*), DY(*), Y_TAIL(*) */ +/* DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT(*), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > DLA_GBRFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by DGBRFSX to perform iterative refinement. */ +/* > In addition to normwise error bound, the code provides maximum */ +/* > componentwise error bound if possible. See comments for ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP for details of the error bounds. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS_TYPE */ +/* > \verbatim */ +/* > TRANS_TYPE is INTEGER */ +/* > Specifies the transposition operation on A. */ +/* > The value is defined by ILATRANS(T) where T is a CHARACTER and T */ +/* > = 'N': No transpose */ +/* > = 'T': Transpose */ +/* > = 'C': Conjugate transpose */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > On entry, the N-by-N matrix AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDBA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by DGBTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AF. LDAFB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by DGBTRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. If C is input, each element of C should be a power */ +/* > of the radix to ensure a reliable solution and error estimates. */ +/* > Scaling by powers of the radix does not cause rounding errors unless */ +/* > the result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by DGBTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by DLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. This can be the same workspace passed for Y_TAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For 'aggressive' set to 100 to */ +/* > permit convergence using approximate factorizations or */ +/* > factorizations other than LU. If the factorization uses a */ +/* > technique other than Gaussian elimination, the guarantees in */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to DGBTRS 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 doubleGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_gbrfsx_extended_(integer *prec_type__, integer * + trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs, + doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, + integer *ipiv, logical *colequ, doublereal *c__, doublereal *b, + integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__, + integer *n_norms__, doublereal *err_bnds_norm__, doublereal * + err_bnds_comp__, doublereal *res, doublereal *ayb, doublereal *dy, + doublereal *y_tail__, doublereal *rcond, integer *ithresh, doublereal + *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + char ch__1[1]; + + /* Local variables */ + doublereal dx_x__, dz_z__; + extern /* Subroutine */ int dla_lin_berr_(integer *, integer *, integer * + , doublereal *, doublereal *, doublereal *); + doublereal ymin; + extern /* Subroutine */ int blas_dgbmv_x_(integer *, integer *, integer * + , integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal dxratmax, dzratmax; + integer y_prec_state__; + extern /* Subroutine */ int blas_dgbmv2_x_(integer *, integer *, integer + *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *, integer *); + integer i__, j, m; + extern /* Subroutine */ int dla_gbamv_(integer *, integer *, integer *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dgbmv_(char *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + char trans[1]; + doublereal normx, normy, myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk; + extern /* Subroutine */ int dgbtrs_(char *, integer *, integer *, integer + *, integer *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + doublereal final_dx_x__; + extern /* Subroutine */ int dla_wwaddw_(integer *, doublereal *, + doublereal *, doublereal *); + doublereal final_dz_z__, normdx; + extern /* Character */ VOID chla_transtype_(char *, integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + chla_transtype_(ch__1, trans_type__); + *(unsigned char *)trans = *(unsigned char *)&ch__1[0]; + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + m = *kl + *ku + 1; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + y_tail__[i__] = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + dgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[ + j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_dgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ + ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, & + res[1], &c__1, prec_type__); + } else { + blas_dgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ + ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], & + c__1, &c_b8, &res[1], &c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + dcopy_(n, &res[1], &c__1, &dy[1], &c__1); + dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] + , &dy[1], n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + yk = (d__1 = y[i__ + j * y_dim1], abs(d__1)); + dyk = (d__1 = dy[i__], abs(d__1)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy + && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + +/* Exit if both normwise and componentwise stopped working, */ +/* but if componentwise is unstable, let it go at least two */ +/* iterations. */ + + if (x_state__ != 1) { + if (*ignore_cwise__) { + goto L666; + } + if (z_state__ == 3 || z_state__ == 2) { + goto L666; + } + if (z_state__ == 0 && cnt > 1) { + goto L666; + } + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + y_tail__[i__] = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + daxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + dla_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). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + dgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j * + y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + dla_gbamv_(trans_type__, n, n, kl, ku, &c_b8, &ab[ab_offset], ldab, & + y[j * y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1); + dla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS */ + + } + + return 0; +} /* dla_gbrfsx_extended__ */ + diff --git a/lapack-netlib/SRC/dla_gbrpvgrw.c b/lapack-netlib/SRC/dla_gbrpvgrw.c new file mode 100644 index 000000000..b4bd2883f --- /dev/null +++ b/lapack-netlib/SRC/dla_gbrpvgrw.c @@ -0,0 +1,569 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded m +atrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GBRPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, */ +/* LDAB, AFB, LDAFB ) */ + +/* INTEGER N, KL, KU, NCOLS, LDAB, LDAFB */ +/* DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_GBRPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, the stability of the LU factorization of the */ +/* > (equilibrated) matrix A could be poor. This also means that the */ +/* > solution X, estimated condition numbers, and error bounds could be */ +/* > unreliable. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCOLS */ +/* > \verbatim */ +/* > NCOLS is INTEGER */ +/* > The number of columns of the matrix A. NCOLS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(KU+1+i-j,j) = A(i,j) for f2cmax(1,j-KU)<=i<=f2cmin(N,j+kl) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by DGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGBcomputational */ + +/* ===================================================================== */ +doublereal dla_gbrpvgrw_(integer *n, integer *kl, integer *ku, integer * + ncols, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + + /* Local variables */ + doublereal amax, umax; + integer i__, j, kd; + doublereal rpvgrw; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + + /* Function Body */ + rpvgrw = 1.; + kd = *ku + 1; + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + amax = 0.; + umax = 0.; +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = f2cmin(i__4,*n); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1)); + amax = f2cmax(d__2,amax); + } +/* Computing MAX */ + i__3 = j - *ku; + i__2 = j; + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = afb[kd + i__ - j + j * afb_dim1], abs(d__1)); + umax = f2cmax(d__2,umax); + } + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + ret_val = rpvgrw; + return ret_val; +} /* dla_gbrpvgrw__ */ + diff --git a/lapack-netlib/SRC/dla_geamv.c b/lapack-netlib/SRC/dla_geamv.c new file mode 100644 index 000000000..c1bde3b28 --- /dev/null +++ b/lapack-netlib/SRC/dla_geamv.c @@ -0,0 +1,779 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GEAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, */ +/* Y, INCY ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER INCX, INCY, LDA, M, N, TRANS */ +/* DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_GEAMV performs one of the matrix-vector operations */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > or y := alpha*abs(A)**T*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > m by n matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is INTEGER */ +/* > On entry, TRANS specifies the operation to be performed as */ +/* > follows: */ +/* > */ +/* > BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */ +/* > BLAS_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > BLAS_CONJ_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of the matrix A. */ +/* > M must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension ( LDA, n ) */ +/* > Before entry, the leading m by n part of the array A must */ +/* > contain the matrix of coefficients. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > On entry, LDA specifies the first dimension of A as declared */ +/* > in the calling (sub) program. LDA must be at least */ +/* > f2cmax( 1, m ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* > Before entry, the incremented array X must contain the */ +/* > vector x. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > On entry, INCX specifies the increment for the elements of */ +/* > X. INCX must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, */ +/* > dimension at least */ +/* > ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > */ +/* > Level 2 Blas routine. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleGEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_geamv_(integer *trans, integer *m, integer *n, + doublereal *alpha, doublereal *a, integer *lda, doublereal *x, + integer *incx, doublereal *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer info; + doublereal temp; + integer lenx, leny; + extern integer ilatrans_(char *); + doublereal safe1; + integer i__, j; + logical symb_zero__; + extern doublereal dlamch_(char *); + integer iy, jx, kx, ky; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < f2cmax(1,*m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("DLA_GEAMV ", &info, (ftnlen)10); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (*trans == ilatrans_("N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = dlamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + iy = ky; + if (*incx == 1) { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[jx] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[jx] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of DLA_GEAMV */ + +} /* dla_geamv__ */ + diff --git a/lapack-netlib/SRC/dla_gercond.c b/lapack-netlib/SRC/dla_gercond.c new file mode 100644 index 000000000..21fcbe7b0 --- /dev/null +++ b/lapack-netlib/SRC/dla_gercond.c @@ -0,0 +1,738 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GERCOND estimates the Skeel condition number for a general matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GERCOND + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, */ +/* LDAF, IPIV, CMODE, C, */ +/* INFO, WORK, IWORK ) */ + +/* CHARACTER TRANS */ +/* INTEGER N, LDA, LDAF, INFO, CMODE */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), */ +/* $ C( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_GERCOND 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] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by DGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by DGETRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleGEcomputational */ + +/* ===================================================================== */ +doublereal dla_gercond_(char *trans, integer *n, doublereal *a, integer *lda, + doublereal *af, integer *ldaf, integer *ipiv, integer *cmode, + doublereal *c__, integer *info, doublereal *work, integer *iwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int dgetrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + doublereal tmp; + logical notrans; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + notrans = lsame_(trans, "N"); + if (! notrans && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLA_GERCOND", &i__1, (ftnlen)11); + return ret_val; + } + if (*n == 0) { + ret_val = 1.; + return ret_val; + } + +/* Compute the equilibration matrix R such that */ +/* inv(R)*A*C has unit 1-norm. */ + + if (notrans) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + } else { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + } + } else { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + kase = 0; +L10: + dlacn2_(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 (notrans) { + dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ + 1], &work[1], n, info); + } else { + dgetrs_("Transpose", 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 (notrans) { + dgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1], + &work[1], n, info); + } else { + dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ + 1], &work[1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* dla_gercond__ */ + diff --git a/lapack-netlib/SRC/dla_gerfsx_extended.c b/lapack-netlib/SRC/dla_gerfsx_extended.c new file mode 100644 index 000000000..688b6ea1f --- /dev/null +++ b/lapack-netlib/SRC/dla_gerfsx_extended.c @@ -0,0 +1,1122 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general +matrices by performing extra-precise iterative refinement and provides error bounds and backward error + estimates for the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GERFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, */ +/* LDA, AF, LDAF, IPIV, COLEQU, C, B, */ +/* LDB, Y, LDY, BERR_OUT, N_NORMS, */ +/* ERRS_N, ERRS_C, RES, AYB, DY, */ +/* Y_TAIL, RCOND, ITHRESH, RTHRESH, */ +/* DZ_UB, IGNORE_CWISE, INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ TRANS_TYPE, N_NORMS, ITHRESH */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), */ +/* $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > DLA_GERFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by DGERFSX to perform iterative refinement. */ +/* > In addition to normwise error bound, the code provides maximum */ +/* > componentwise error bound if possible. See comments for ERRS_N */ +/* > and ERRS_C for details of the error bounds. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERRS_N and ERRS_C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS_TYPE */ +/* > \verbatim */ +/* > TRANS_TYPE is INTEGER */ +/* > Specifies the transposition operation on A. */ +/* > The value is defined by ILATRANS(T) where T is a CHARACTER and T */ +/* > = 'N': No transpose */ +/* > = 'T': Transpose */ +/* > = 'C': Conjugate transpose */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by DGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by DGETRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. If C is input, each element of C should be a power */ +/* > of the radix to ensure a reliable solution and error estimates. */ +/* > Scaling by powers of the radix does not cause rounding errors unless */ +/* > the result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by DGETRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by DLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERRS_N */ +/* > and ERRS_C). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERRS_N */ +/* > \verbatim */ +/* > ERRS_N is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERRS_N(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERRS_N(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERRS_C */ +/* > \verbatim */ +/* > ERRS_C is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERRS_C is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERRS_C(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERRS_C(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. This can be the same workspace passed for Y_TAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For 'aggressive' set to 100 to */ +/* > permit convergence using approximate factorizations or */ +/* > factorizations other than LU. If the factorization uses a */ +/* > technique other than Gaussian elimination, the guarantees in */ +/* > ERRS_N and ERRS_C may no longer be trustworthy. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to DGETRS 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 doubleGEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_gerfsx_extended_(integer *prec_type__, integer * + trans_type__, integer *n, integer *nrhs, doublereal *a, integer *lda, + doublereal *af, integer *ldaf, integer *ipiv, logical *colequ, + doublereal *c__, doublereal *b, integer *ldb, doublereal *y, integer * + ldy, doublereal *berr_out__, integer *n_norms__, doublereal *errs_n__, + doublereal *errs_c__, doublereal *res, doublereal *ayb, doublereal * + dy, doublereal *y_tail__, doublereal *rcond, integer *ithresh, + doublereal *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, errs_n_dim1, errs_n_offset, errs_c_dim1, errs_c_offset, + i__1, i__2, i__3; + doublereal d__1, d__2; + char ch__1[1]; + + /* Local variables */ + doublereal dx_x__, dz_z__; + extern /* Subroutine */ int dla_lin_berr_(integer *, integer *, integer * + , doublereal *, doublereal *, doublereal *); + doublereal ymin; + extern /* Subroutine */ int blas_dgemv_x_(integer *, integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *); + doublereal dxratmax, dzratmax; + integer y_prec_state__, i__, j; + extern /* Subroutine */ int blas_dgemv2_x_(integer *, integer *, integer + *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *), dla_geamv_(integer *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dgemv_(char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), dcopy_( + integer *, doublereal *, integer *, doublereal *, integer *); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + char trans[1]; + doublereal normx, normy, myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk, final_dx_x__; + extern /* Subroutine */ int dgetrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *), dla_wwaddw_(integer *, doublereal *, + doublereal *, doublereal *); + doublereal final_dz_z__, normdx; + extern /* Character */ VOID chla_transtype_(char *, integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + errs_c_dim1 = *nrhs; + errs_c_offset = 1 + errs_c_dim1 * 1; + errs_c__ -= errs_c_offset; + errs_n_dim1 = *nrhs; + errs_n_offset = 1 + errs_n_dim1 * 1; + errs_n__ -= errs_n_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + chla_transtype_(ch__1, trans_type__); + *(unsigned char *)trans = *(unsigned char *)&ch__1[0]; + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + y_tail__[i__] = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + dgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + + 1], &c__1, &c_b8, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_dgemv_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, & + y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1, + prec_type__); + } else { + blas_dgemv2_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, + &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b8, &res[ + 1], &c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + dcopy_(n, &res[1], &c__1, &dy[1], &c__1); + dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], + n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + yk = (d__1 = y[i__ + j * y_dim1], abs(d__1)); + dyk = (d__1 = dy[i__], abs(d__1)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria */ + + if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy + && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + +/* Exit if both normwise and componentwise stopped working, */ +/* but if componentwise is unstable, let it go at least two */ +/* iterations. */ + + if (x_state__ != 1) { + if (*ignore_cwise__) { + goto L666; + } + if (z_state__ == 3 || z_state__ == 2) { + goto L666; + } + if (z_state__ == 0 && cnt > 1) { + goto L666; + } + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + y_tail__[i__] = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + daxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + dla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds */ + + if (*n_norms__ >= 1) { + errs_n__[j + (errs_n_dim1 << 1)] = final_dx_x__ / (1 - dxratmax); + } + if (*n_norms__ >= 2) { + errs_c__[j + (errs_c_dim1 << 1)] = final_dz_z__ / (1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + dgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + 1], & + c__1, &c_b8, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + dla_geamv_(trans_type__, n, n, &c_b8, &a[a_offset], lda, &y[j * + y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1); + dla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* dla_gerfsx_extended__ */ + diff --git a/lapack-netlib/SRC/dla_gerpvgrw.c b/lapack-netlib/SRC/dla_gerpvgrw.c new file mode 100644 index 000000000..fda054bce --- /dev/null +++ b/lapack-netlib/SRC/dla_gerpvgrw.c @@ -0,0 +1,544 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_GERPVGRW */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_GERPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_GERPVGRW( N, NCOLS, A, LDA, AF, */ +/* LDAF ) */ + +/* INTEGER N, NCOLS, LDA, LDAF */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > DLA_GERPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, the stability of the LU factorization of the */ +/* > (equilibrated) matrix A could be poor. This also means that the */ +/* > solution X, estimated condition numbers, and error bounds could be */ +/* > unreliable. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCOLS */ +/* > \verbatim */ +/* > NCOLS is INTEGER */ +/* > The number of columns of the matrix A. NCOLS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by DGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGEcomputational */ + +/* ===================================================================== */ +doublereal dla_gerpvgrw_(integer *n, integer *ncols, doublereal *a, integer * + lda, doublereal *af, integer *ldaf) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + doublereal ret_val, d__1, d__2; + + /* Local variables */ + doublereal amax, umax; + integer i__, j; + doublereal rpvgrw; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* 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; + + /* Function Body */ + rpvgrw = 1.; + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + amax = 0.; + umax = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + amax = f2cmax(d__2,amax); + } + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = af[i__ + j * af_dim1], abs(d__1)); + umax = f2cmax(d__2,umax); + } + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + ret_val = rpvgrw; + return ret_val; +} /* dla_gerpvgrw__ */ + diff --git a/lapack-netlib/SRC/dla_lin_berr.c b/lapack-netlib/SRC/dla_lin_berr.c new file mode 100644 index 000000000..7a371fb9a --- /dev/null +++ b/lapack-netlib/SRC/dla_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 DLA_LIN_BERR computes a component-wise relative backward error. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_LIN_BERR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) */ + +/* INTEGER N, NZ, NRHS */ +/* DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) */ +/* DOUBLE PRECISION RES( N, NRHS ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_LIN_BERR computes component-wise 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 component-wise 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 DOUBLE PRECISION array, dimension (N,NRHS) */ +/* > The residual matrix, i.e., the matrix R in the relative backward */ +/* > error formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N, NRHS) */ +/* > The denominator in the relative backward error formula above, i.e., */ +/* > the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */ +/* > are from iterative refinement (see dla_gerfsx_extended.f). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The component-wise 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 doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_lin_berr_(integer *n, integer *nz, integer *nrhs, + doublereal *res, doublereal *ayb, doublereal *berr) +{ + /* System generated locals */ + integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal safe1; + integer i__, j; + extern doublereal dlamch_(char *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* 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 = dlamch_("Safe minimum"); + safe1 = (*nz + 1) * safe1; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (ayb[i__ + j * ayb_dim1] != 0.) { + tmp = (safe1 + (d__1 = res[i__ + j * res_dim1], abs(d__1))) / + ayb[i__ + j * ayb_dim1]; +/* Computing MAX */ + d__1 = berr[j]; + berr[j] = f2cmax(d__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; +} /* dla_lin_berr__ */ + diff --git a/lapack-netlib/SRC/dla_porcond.c b/lapack-netlib/SRC/dla_porcond.c new file mode 100644 index 000000000..425a5f1c7 --- /dev/null +++ b/lapack-netlib/SRC/dla_porcond.c @@ -0,0 +1,746 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_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 DLA_PORCOND + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, */ +/* CMODE, C, INFO, WORK, */ +/* IWORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LDAF, INFO, CMODE */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), */ +/* $ C( * ) */ +/* INTEGER IWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DPOTRF. */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doublePOcomputational */ + +/* ===================================================================== */ +doublereal dla_porcond_(char *uplo, integer *n, doublereal *a, integer *lda, + doublereal *af, integer *ldaf, integer *cmode, doublereal *c__, + integer *info, doublereal *work, integer *iwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int dpotrs_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLA_PORCOND", &i__1, (ftnlen)11); + return ret_val; + } + if (*n == 0) { + ret_val = 1.; + 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.; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + kase = 0; +L10: + dlacn2_(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) { + dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + dpotrs_("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) { + dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + dpotrs_("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.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* dla_porcond__ */ + diff --git a/lapack-netlib/SRC/dla_porfsx_extended.c b/lapack-netlib/SRC/dla_porfsx_extended.c new file mode 100644 index 000000000..a83c05f32 --- /dev/null +++ b/lapack-netlib/SRC/dla_porfsx_extended.c @@ -0,0 +1,1098 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_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 DLA_PORFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, */ +/* AF, LDAF, COLEQU, C, B, LDB, Y, */ +/* LDY, BERR_OUT, N_NORMS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, */ +/* AYB, DY, Y_TAIL, RCOND, ITHRESH, */ +/* RTHRESH, DZ_UB, IGNORE_CWISE, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ N_NORMS, ITHRESH */ +/* CHARACTER UPLO */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_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 DPORFSX 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. If C is input, each element of C should be a power */ +/* > of the radix to ensure a reliable solution and error estimates. */ +/* > Scaling by powers of the radix does not cause rounding errors unless */ +/* > the result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by DPOTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by DLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. This can be the same workspace passed for Y_TAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For 'aggressive' set to 100 to */ +/* > permit convergence using approximate factorizations or */ +/* > factorizations other than LU. If the factorization uses a */ +/* > technique other than Gaussian elimination, the guarantees in */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to DPOTRS 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 doublePOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_porfsx_extended_(integer *prec_type__, char *uplo, + integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal * + af, integer *ldaf, logical *colequ, doublereal *c__, doublereal *b, + integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__, + integer *n_norms__, doublereal *err_bnds_norm__, doublereal * + err_bnds_comp__, doublereal *res, doublereal *ayb, doublereal *dy, + doublereal *y_tail__, doublereal *rcond, integer *ithresh, doublereal + *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + doublereal dx_x__, dz_z__; + extern /* Subroutine */ int dla_lin_berr_(integer *, integer *, integer * + , doublereal *, doublereal *, doublereal *); + doublereal ymin, dxratmax, dzratmax; + integer y_prec_state__; + extern /* Subroutine */ int blas_dsymv_x_(integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *); + integer uplo2, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int blas_dsymv2_x_(integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer * + ); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dla_syamv_(integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), dsymv_(char *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + doublereal normx, normy, myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk, final_dx_x__; + extern /* Subroutine */ int dla_wwaddw_(integer *, doublereal *, + doublereal *, doublereal *); + doublereal final_dz_z__, normdx; + extern /* Subroutine */ int dpotrs_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + extern integer ilauplo_(char *); + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + if (lsame_(uplo, "L")) { + uplo2 = ilauplo_("L"); + } else { + uplo2 = ilauplo_("U"); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + y_tail__[i__] = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + dsymv_(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_dsymv_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_dsymv2_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. */ + dcopy_(n, &res[1], &c__1, &dy[1], &c__1); + dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &dy[1], n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + yk = (d__1 = y[i__ + j * y_dim1], abs(d__1)); + dyk = (d__1 = dy[i__], abs(d__1)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { + goto L666; + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + y_tail__[i__] = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + daxpy_(n, &c_b11, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + dla_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). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + dsymv_(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__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + dla_syamv_(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b11, &ayb[1], &c__1); + dla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* dla_porfsx_extended__ */ + diff --git a/lapack-netlib/SRC/dla_porpvgrw.c b/lapack-netlib/SRC/dla_porpvgrw.c new file mode 100644 index 000000000..f67729956 --- /dev/null +++ b/lapack-netlib/SRC/dla_porpvgrw.c @@ -0,0 +1,626 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_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 DLA_PORPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, */ +/* LDAF, WORK ) */ + +/* CHARACTER*1 UPLO */ +/* INTEGER NCOLS, LDA, LDAF */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > DLA_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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doublePOcomputational */ + +/* ===================================================================== */ +doublereal dla_porpvgrw_(char *uplo, integer *ncols, doublereal *a, integer * + lda, doublereal *af, integer *ldaf, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + doublereal ret_val, d__1, d__2, d__3; + + /* Local variables */ + doublereal amax, umax; + integer i__, j; + extern logical lsame_(char *, char *); + logical upper; + doublereal rpvgrw; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* 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); + +/* DPOTRF will have factored only the NCOLSxNCOLS leading minor, so */ +/* we restrict the growth search to that minor and use only the first */ +/* 2*NCOLS workspace entries. */ + + rpvgrw = 1.; + i__1 = *ncols << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + +/* Find the f2cmax magnitude entry of each column. */ + + if (upper) { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[* + ncols + j]; + work[*ncols + j] = f2cmax(d__2,d__3); + } + } + } else { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = *ncols; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[* + ncols + j]; + work[*ncols + j] = f2cmax(d__2,d__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 */ + d__2 = (d__1 = af[i__ + j * af_dim1], abs(d__1)), d__3 = work[ + j]; + work[j] = f2cmax(d__2,d__3); + } + } + } else { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = *ncols; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = af[i__ + j * af_dim1], abs(d__1)), d__3 = work[ + j]; + work[j] = f2cmax(d__2,d__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.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } else { + i__1 = *ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*ncols + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } + ret_val = rpvgrw; + return ret_val; +} /* dla_porpvgrw__ */ + diff --git a/lapack-netlib/SRC/dla_syamv.c b/lapack-netlib/SRC/dla_syamv.c new file mode 100644 index 000000000..59be90bfa --- /dev/null +++ b/lapack-netlib/SRC/dla_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 DLA_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 DLA_SYAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, */ +/* INCY ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER INCX, INCY, LDA, N, UPLO */ +/* DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_SYAMV performs the matrix-vector operation */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > n by n symmetric matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is INTEGER */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the array A is to be referenced as */ +/* > follows: */ +/* > */ +/* > UPLO = BLAS_UPPER Only the upper triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > UPLO = BLAS_LOWER Only the lower triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION . */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION . */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \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 dla_syamv_(integer *uplo, integer *n, doublereal *alpha, + doublereal *a, integer *lda, doublereal *x, integer *incx, + doublereal *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer info; + doublereal temp, safe1; + integer i__, j; + logical symb_zero__; + extern doublereal dlamch_(char *); + integer iy, jx, kx, ky; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilauplo_(char *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L") + ) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < f2cmax(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("DLA_SYAMV", &info, (ftnlen)9); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = dlamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + iy = ky; + if (*incx == 1) { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + jx = kx; + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + jx = kx; + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + symb_zero__ = symb_zero__ && (x[j] == 0. || temp == + 0.); + y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of DLA_SYAMV */ + +} /* dla_syamv__ */ + diff --git a/lapack-netlib/SRC/dla_syrcond.c b/lapack-netlib/SRC/dla_syrcond.c new file mode 100644 index 000000000..8a3e2339f --- /dev/null +++ b/lapack-netlib/SRC/dla_syrcond.c @@ -0,0 +1,764 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_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 DLA_SYRCOND + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, */ +/* IPIV, CMODE, C, INFO, WORK, */ +/* IWORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LDAF, INFO, CMODE */ +/* INTEGER IWORK( * ), IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleSYcomputational */ + +/* ===================================================================== */ +doublereal dla_syrcond_(char *uplo, integer *n, doublereal *a, integer *lda, + doublereal *af, integer *ldaf, integer *ipiv, integer *cmode, + doublereal *c__, integer *info, doublereal *work, integer *iwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + char normin[1]; + doublereal smlnum; + extern /* Subroutine */ int dsytrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.; + + *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_("DLA_SYRCOND", &i__1, (ftnlen)11); + return ret_val; + } + if (*n == 0) { + ret_val = 1.; + 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.; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + smlnum = dlamch_("Safe minimum"); + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + kase = 0; +L10: + dlacn2_(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) { + dsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + dsytrs_("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) { + dsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + dsytrs_("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.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* dla_syrcond__ */ + diff --git a/lapack-netlib/SRC/dla_syrfsx_extended.c b/lapack-netlib/SRC/dla_syrfsx_extended.c new file mode 100644 index 000000000..d730e0a6a --- /dev/null +++ b/lapack-netlib/SRC/dla_syrfsx_extended.c @@ -0,0 +1,1132 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_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 DLA_SYRFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, */ +/* AF, LDAF, IPIV, COLEQU, C, B, LDB, */ +/* Y, LDY, BERR_OUT, N_NORMS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, */ +/* AYB, DY, Y_TAIL, RCOND, ITHRESH, */ +/* RTHRESH, DZ_UB, IGNORE_CWISE, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ N_NORMS, ITHRESH */ +/* CHARACTER UPLO */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > DLA_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 DSYRFSX 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. If C is input, each element of C should be a power */ +/* > of the radix to ensure a reliable solution and error estimates. */ +/* > Scaling by powers of the radix does not cause rounding errors unless */ +/* > the result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by DSYTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by DLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. This can be the same workspace passed for Y_TAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For 'aggressive' set to 100 to */ +/* > permit convergence using approximate factorizations or */ +/* > factorizations other than LU. If the factorization uses a */ +/* > technique other than Gaussian elimination, the guarantees in */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to DLA_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 June 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_syrfsx_extended_(integer *prec_type__, char *uplo, + integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal * + af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c__, + doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal * + berr_out__, integer *n_norms__, doublereal *err_bnds_norm__, + doublereal *err_bnds_comp__, doublereal *res, doublereal *ayb, + doublereal *dy, doublereal *y_tail__, doublereal *rcond, integer * + ithresh, doublereal *rthresh, doublereal *dz_ub__, logical * + ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + doublereal dx_x__, dz_z__; + extern /* Subroutine */ int dla_lin_berr_(integer *, integer *, integer * + , doublereal *, doublereal *, doublereal *); + doublereal ymin, dxratmax, dzratmax; + integer y_prec_state__; + extern /* Subroutine */ int blas_dsymv_x_(integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *); + integer uplo2, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int blas_dsymv2_x_(integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer * + ); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dla_syamv_(integer *, integer *, doublereal * + , doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dsymv_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + doublereal normx, normy, myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal final_dx_x__; + extern /* Subroutine */ int dla_wwaddw_(integer *, doublereal *, + doublereal *, doublereal *); + doublereal final_dz_z__, normdx; + extern /* Subroutine */ int dsytrs_(char *, integer *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + extern integer ilauplo_(char *); + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldy < f2cmax(1,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLA_SYRFSX_EXTENDED", &i__1, (ftnlen)19); + return 0; + } + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + if (lsame_(uplo, "L")) { + uplo2 = ilauplo_("L"); + } else { + uplo2 = ilauplo_("U"); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + y_tail__[i__] = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + dsymv_(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_dsymv_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_dsymv2_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. */ + dcopy_(n, &res[1], &c__1, &dy[1], &c__1); + dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], n, + info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + yk = (d__1 = y[i__ + j * y_dim1], abs(d__1)); + dyk = (d__1 = dy[i__], abs(d__1)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { + goto L666; + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + y_tail__[i__] = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + daxpy_(n, &c_b14, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + dla_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). */ + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + dsymv_(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__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + dla_syamv_(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b14, &ayb[1], &c__1); + dla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* dla_syrfsx_extended__ */ + diff --git a/lapack-netlib/SRC/dla_syrpvgrw.c b/lapack-netlib/SRC/dla_syrpvgrw.c new file mode 100644 index 000000000..9cb586886 --- /dev/null +++ b/lapack-netlib/SRC/dla_syrpvgrw.c @@ -0,0 +1,764 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_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 DLA_SYRPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, */ +/* LDAF, IPIV, WORK ) */ + +/* CHARACTER*1 UPLO */ +/* INTEGER N, INFO, LDA, LDAF */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > DLA_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 DSYTRF, .i.e., the pivot in */ +/* > column INFO is exactly 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +doublereal dla_syrpvgrw_(char *uplo, integer *n, integer *info, doublereal * + a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, + doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + doublereal ret_val, d__1, d__2, d__3; + + /* Local variables */ + doublereal amax, umax; + integer i__, j, k; + extern logical lsame_(char *, char *); + integer ncols; + logical upper; + integer kp; + doublereal rpvgrw, tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --work; + + /* Function Body */ + upper = lsame_("Upper", uplo); + if (*info == 0) { + if (upper) { + ncols = 1; + } else { + ncols = *n; + } + } else { + ncols = *info; + } + rpvgrw = 1.; + i__1 = *n << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + +/* Find the f2cmax magnitude entry of each column of A. Compute the f2cmax */ +/* for all N columns so we can apply the pivot permutation while */ +/* looping below. Assume a full factorization is the common case. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[* + n + i__]; + work[*n + i__] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[* + n + j]; + work[*n + j] = f2cmax(d__2,d__3); + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[* + n + i__]; + work[*n + i__] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[* + n + j]; + work[*n + j] = f2cmax(d__2,d__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 dsytrs. */ +/* 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 */ + d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 = + work[k]; + work[k] = f2cmax(d__2,d__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 */ + d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 = + work[k]; + work[k] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = (d__1 = af[i__ + (k - 1) * af_dim1], abs(d__1)), + d__3 = work[k - 1]; + work[k - 1] = f2cmax(d__2,d__3); + } +/* Computing MAX */ + d__2 = (d__1 = af[k + k * af_dim1], abs(d__1)), d__3 = work[k] + ; + work[k] = f2cmax(d__2,d__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 */ + d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 = + work[k]; + work[k] = f2cmax(d__2,d__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 */ + d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 = + work[k]; + work[k] = f2cmax(d__2,d__3); +/* Computing MAX */ + d__2 = (d__1 = af[i__ + (k + 1) * af_dim1], abs(d__1)), + d__3 = work[k + 1]; + work[k + 1] = f2cmax(d__2,d__3); + } +/* Computing MAX */ + d__2 = (d__1 = af[k + k * af_dim1], abs(d__1)), d__3 = work[k] + ; + work[k] = f2cmax(d__2,d__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.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } else { + i__1 = ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*n + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } + ret_val = rpvgrw; + return ret_val; +} /* dla_syrpvgrw__ */ + diff --git a/lapack-netlib/SRC/dla_wwaddw.c b/lapack-netlib/SRC/dla_wwaddw.c new file mode 100644 index 000000000..0a8d8d01e --- /dev/null +++ b/lapack-netlib/SRC/dla_wwaddw.c @@ -0,0 +1,505 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLA_WWADDW adds a vector into a doubled-single vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLA_WWADDW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLA_WWADDW( N, X, Y, W ) */ + +/* INTEGER N */ +/* DOUBLE PRECISION X( * ), Y( * ), W( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLA_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 DOUBLE PRECISION array, dimension (N) */ +/* > The first part of the doubled-single accumulation vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension (N) */ +/* > The second part of the doubled-single accumulation vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION 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 doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dla_wwaddw_(integer *n, doublereal *x, doublereal *y, + doublereal *w) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__; + doublereal 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; +} /* dla_wwaddw__ */ + diff --git a/lapack-netlib/SRC/dlabad.c b/lapack-netlib/SRC/dlabad.c new file mode 100644 index 000000000..b57e8a1ad --- /dev/null +++ b/lapack-netlib/SRC/dlabad.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 DLABAD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLABAD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLABAD( SMALL, LARGE ) */ + +/* DOUBLE PRECISION LARGE, SMALL */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLABAD takes as input the values computed by DLAMCH 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 DLAMCH. This subroutine is needed because */ +/* > DLAMCH 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 DOUBLE PRECISION */ +/* > On entry, the underflow threshold as computed by DLAMCH. */ +/* > On exit, if LOG10(LARGE) is sufficiently large, the square */ +/* > root of SMALL, otherwise unchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] LARGE */ +/* > \verbatim */ +/* > LARGE is DOUBLE PRECISION */ +/* > On entry, the overflow threshold as computed by DLAMCH. */ +/* > 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 dlabad_(doublereal *small, doublereal *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 (d_lg10(large) > 2e3) { + *small = sqrt(*small); + *large = sqrt(*large); + } + + return 0; + +/* End of DLABAD */ + +} /* dlabad_ */ + diff --git a/lapack-netlib/SRC/dlabrd.c b/lapack-netlib/SRC/dlabrd.c new file mode 100644 index 000000000..4633ac568 --- /dev/null +++ b/lapack-netlib/SRC/dlabrd.c @@ -0,0 +1,885 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLABRD 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 DLABRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, */ +/* LDY ) */ + +/* INTEGER LDA, LDX, LDY, M, N, NB */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), */ +/* $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLABRD 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 DGEBRD */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (NB) */ +/* > The diagonal elements of the first NB rows and columns of */ +/* > the reduced matrix. D(i) = A(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (NB) */ +/* > The off-diagonal elements of the first NB rows and columns of */ +/* > the reduced matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ */ +/* > \verbatim */ +/* > TAUQ is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* > \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 dlabrd_(integer *m, integer *n, integer *nb, doublereal * + a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq, + doublereal *taup, doublereal *x, integer *ldx, doublereal *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 dscal_(integer *, doublereal *, doublereal *, + integer *), dgemv_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dlarfg_(integer *, doublereal *, + doublereal *, integer *, doublereal *); + + +/* -- 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; + dgemv_("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; + dgemv_("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; + dlarfg_(&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.; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dgemv_("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; + dgemv_("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; + dgemv_("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; + dgemv_("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__; + dgemv_("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__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + +/* Update A(i,i+1:n) */ + + i__2 = *n - i__; + dgemv_("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__; + dgemv_("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; + dlarfg_(&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.; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_("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__; + dgemv_("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__; + dgemv_("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__; + dgemv_("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; + dgemv_("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__; + dscal_(&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; + dgemv_("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; + dgemv_("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; + dlarfg_(&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.; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dgemv_("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; + dgemv_("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; + dgemv_("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; + dgemv_("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; + dgemv_("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__; + dscal_(&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; + dgemv_("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__; + dgemv_("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; + dlarfg_(&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.; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_("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; + dgemv_("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; + dgemv_("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__; + dgemv_("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__; + dgemv_("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__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + } +/* L20: */ + } + } + return 0; + +/* End of DLABRD */ + +} /* dlabrd_ */ + diff --git a/lapack-netlib/SRC/dlacn2.c b/lapack-netlib/SRC/dlacn2.c new file mode 100644 index 000000000..ebab55d0d --- /dev/null +++ b/lapack-netlib/SRC/dlacn2.c @@ -0,0 +1,702 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLACN2 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 DLACN2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) */ + +/* INTEGER KASE, N */ +/* DOUBLE PRECISION EST */ +/* INTEGER ISGN( * ), ISAVE( 3 ) */ +/* DOUBLE PRECISION V( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLACN2 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > On an intermediate return, X should be overwritten by */ +/* > A * X, if KASE=1, */ +/* > A**T * X, if KASE=2, */ +/* > and DLACN2 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 DOUBLE PRECISION */ +/* > On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */ +/* > unchanged from the previous call to DLACN2. */ +/* > 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 DLACN2, 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 DLACN2, 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 DLACN2 */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Originally named SONEST, dated March 16, 1988. */ +/* > */ +/* > This is a thread safe version of DLACON, which uses the array ISAVE */ +/* > in place of a SAVE statement, as follows: */ +/* > */ +/* > DLACON DLACN2 */ +/* > 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 dlacn2_(integer *n, doublereal *v, doublereal *x, + integer *isgn, doublereal *est, integer *kase, integer *isave) +{ + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + doublereal temp; + integer i__; + extern doublereal dasum_(integer *, doublereal *, integer *); + integer jlast; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + doublereal 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. / (doublereal) (*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 = dasum_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&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] = idamax_(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.; +/* L60: */ + } + x[isave[2]] = 1.; + *kase = 1; + isave[1] = 3; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = dasum_(n, &v[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = d_sign(&c_b11, &x[i__]); + if (i_dnnt(&d__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__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&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] = idamax_(n, &x[1], &c__1); + if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) { + ++isave[3]; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L120: + altsgn = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + + 1.); + altsgn = -altsgn; +/* L130: */ + } + *kase = 1; + isave[1] = 5; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L140: + temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; + if (temp > *est) { + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L150: + *kase = 0; + return 0; + +/* End of DLACN2 */ + +} /* dlacn2_ */ + diff --git a/lapack-netlib/SRC/dlacon.c b/lapack-netlib/SRC/dlacon.c new file mode 100644 index 000000000..25b8f2d7a --- /dev/null +++ b/lapack-netlib/SRC/dlacon.c @@ -0,0 +1,681 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLACON 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 DLACON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) */ + +/* INTEGER KASE, N */ +/* DOUBLE PRECISION EST */ +/* INTEGER ISGN( * ) */ +/* DOUBLE PRECISION V( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLACON 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > On an intermediate return, X should be overwritten by */ +/* > A * X, if KASE=1, */ +/* > A**T * X, if KASE=2, */ +/* > and DLACON 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 DOUBLE PRECISION */ +/* > On entry with KASE = 1 or 2 and JUMP = 3, EST should be */ +/* > unchanged from the previous call to DLACON. */ +/* > 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 DLACON, 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 DLACON, 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 doubleOTHERauxiliary */ + +/* > \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 dlacon_(integer *n, doublereal *v, doublereal *x, + integer *isgn, doublereal *est, integer *kase) +{ + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + static integer iter; + static doublereal temp; + static integer jump, i__, j; + extern doublereal dasum_(integer *, doublereal *, integer *); + static integer jlast; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + static doublereal 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. / (doublereal) (*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 = dasum_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&x[i__]); +/* L30: */ + } + *kase = 2; + jump = 2; + return 0; + +/* ................ ENTRY (JUMP = 2) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L40: + j = idamax_(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.; +/* L60: */ + } + x[j] = 1.; + *kase = 1; + jump = 3; + return 0; + +/* ................ ENTRY (JUMP = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = dasum_(n, &v[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = d_sign(&c_b11, &x[i__]); + if (i_dnnt(&d__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__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&x[i__]); +/* L100: */ + } + *kase = 2; + jump = 4; + return 0; + +/* ................ ENTRY (JUMP = 4) */ +/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L110: + jlast = j; + j = idamax_(n, &x[1], &c__1); + if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) { + ++iter; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L120: + altsgn = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + + 1.); + altsgn = -altsgn; +/* L130: */ + } + *kase = 1; + jump = 5; + return 0; + +/* ................ ENTRY (JUMP = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L140: + temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; + if (temp > *est) { + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L150: + *kase = 0; + return 0; + +/* End of DLACON */ + +} /* dlacon_ */ + diff --git a/lapack-netlib/SRC/dlacpy.c b/lapack-netlib/SRC/dlacpy.c new file mode 100644 index 000000000..68812726c --- /dev/null +++ b/lapack-netlib/SRC/dlacpy.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 DLACPY 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 DLACPY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, LDB, M, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLACPY 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dlacpy_(char *uplo, integer *m, integer *n, doublereal * + a, integer *lda, doublereal *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 DLACPY */ + +} /* dlacpy_ */ + diff --git a/lapack-netlib/SRC/dladiv.c b/lapack-netlib/SRC/dladiv.c new file mode 100644 index 000000000..226af8de8 --- /dev/null +++ b/lapack-netlib/SRC/dladiv.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 DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLADIV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLADIV( A, B, C, D, P, Q ) */ + +/* DOUBLE PRECISION A, B, C, D, P, Q */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLADIV 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 DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION */ +/* > The scalars a, b, c, and d in the above expression. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] P */ +/* > \verbatim */ +/* > P is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION */ +/* > 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *d__, doublereal *p, doublereal *q) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Local variables */ + doublereal s, aa, ab, bb, cc, cd, dd, be; + extern doublereal dlamch_(char *); + doublereal un, ov; + extern /* Subroutine */ int dladiv1_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + doublereal 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 */ + d__1 = abs(*a), d__2 = abs(*b); + ab = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = abs(*c__), d__2 = abs(*d__); + cd = f2cmax(d__1,d__2); + s = 1.; + ov = dlamch_("Overflow threshold"); + un = dlamch_("Safe minimum"); + eps = dlamch_("Epsilon"); + be = 2. / (eps * eps); + if (ab >= ov * .5) { + aa *= .5; + bb *= .5; + s *= 2.; + } + if (cd >= ov * .5) { + cc *= .5; + dd *= .5; + s *= .5; + } + if (ab <= un * 2. / eps) { + aa *= be; + bb *= be; + s /= be; + } + if (cd <= un * 2. / eps) { + cc *= be; + dd *= be; + s *= be; + } + if (abs(*d__) <= abs(*c__)) { + dladiv1_(&aa, &bb, &cc, &dd, p, q); + } else { + dladiv1_(&bb, &aa, &dd, &cc, p, q); + *q = -(*q); + } + *p *= s; + *q *= s; + + return 0; + +/* End of DLADIV */ + +} /* dladiv_ */ + +/* > \ingroup doubleOTHERauxiliary */ +/* Subroutine */ int dladiv1_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *d__, doublereal *p, doublereal *q) +{ + doublereal r__, t; + extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + + +/* -- 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. / (*c__ + *d__ * r__); + *p = dladiv2_(a, b, c__, d__, &r__, &t); + *a = -(*a); + *q = dladiv2_(b, a, c__, d__, &r__, &t); + + return 0; + +/* End of DLADIV1 */ + +} /* dladiv1_ */ + +/* > \ingroup doubleOTHERauxiliary */ +doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal + *d__, doublereal *r__, doublereal *t) +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + doublereal 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.) { + br = *b * *r__; + if (br != 0.) { + 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 DLADIV12 */ + +} /* dladiv2_ */ + diff --git a/lapack-netlib/SRC/dlae2.c b/lapack-netlib/SRC/dlae2.c new file mode 100644 index 000000000..7b36c658b --- /dev/null +++ b/lapack-netlib/SRC/dlae2.c @@ -0,0 +1,567 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAE2 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 DLAE2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) */ + +/* DOUBLE PRECISION A, B, C, RT1, RT2 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAE2 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 DOUBLE PRECISION */ +/* > The (1,1) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION */ +/* > The (1,2) and (2,1) elements of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION */ +/* > The (2,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1 */ +/* > \verbatim */ +/* > RT1 is DOUBLE PRECISION */ +/* > The eigenvalue of larger absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2 */ +/* > \verbatim */ +/* > RT2 is DOUBLE PRECISION */ +/* > 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 dlae2_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *rt1, doublereal *rt2) +{ + /* System generated locals */ + doublereal d__1; + + /* Local variables */ + doublereal 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 */ + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); + } else if (adf < ab) { +/* Computing 2nd power */ + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); + } else { + +/* Includes case AB=ADF=0 */ + + rt = ab * sqrt(2.); + } + if (sm < 0.) { + *rt1 = (sm - rt) * .5; + +/* 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.) { + *rt1 = (sm + rt) * .5; + +/* 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 * .5; + *rt2 = rt * -.5; + } + return 0; + +/* End of DLAE2 */ + +} /* dlae2_ */ + diff --git a/lapack-netlib/SRC/dlaebz.c b/lapack-netlib/SRC/dlaebz.c new file mode 100644 index 000000000..37883eeff --- /dev/null +++ b/lapack-netlib/SRC/dlaebz.c @@ -0,0 +1,1100 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAEBZ 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 DLAEBZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAEBZ( 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 */ +/* DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL */ +/* INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) */ +/* DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAEBZ 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 DLAEBZ 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 DLAEBZ 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLAEBZ 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 DLAEBZ is called. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION 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, DLAEBZ should have one or */ +/* > more initial intervals set up in AB, and DLAEBZ 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. DLAEBZ 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). DLAEBZ 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 dlaebz_(integer *ijob, integer *nitmax, integer *n, + integer *mmax, integer *minp, integer *nbmin, doublereal *abstol, + doublereal *reltol, doublereal *pivmin, doublereal *d__, doublereal * + e, doublereal *e2, integer *nval, doublereal *ab, doublereal *c__, + integer *mout, integer *nab, doublereal *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; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer itmp1, itmp2, j, kfnew, klnew, kf, ji, kl, jp, jit; + doublereal 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.) { + 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.) { + ++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)]) * .5; +/* 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 */ + d__1 = work[ji], d__2 = -(*pivmin); + work[ji] = f2cmin(d__1,d__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 */ + d__1 = work[ji], d__2 = -(*pivmin); + work[ji] = f2cmin(d__1,d__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 */ + d__1 = tmp2, d__2 = -(*pivmin); + tmp2 = f2cmin(d__1,d__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 */ + d__1 = tmp2, d__2 = -(*pivmin); + tmp2 = f2cmin(d__1,d__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 = (d__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], abs( + d__1)); +/* Computing MAX */ + d__3 = (d__1 = ab[ji + (ab_dim1 << 1)], abs(d__1)), d__4 = (d__2 = + ab[ji + ab_dim1], abs(d__2)); + tmp2 = f2cmax(d__3,d__4); +/* Computing MAX */ + d__1 = f2cmax(*abstol,*pivmin), d__2 = *reltol * tmp2; + if (tmp1 < f2cmax(d__1,d__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)]) * .5; +/* 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 DLAEBZ */ + +} /* dlaebz_ */ + diff --git a/lapack-netlib/SRC/dlaed0.c b/lapack-netlib/SRC/dlaed0.c new file mode 100644 index 000000000..aecd291eb --- /dev/null +++ b/lapack-netlib/SRC/dlaed0.c @@ -0,0 +1,880 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED0 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 DLAED0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, */ +/* WORK, IWORK, INFO ) */ + +/* INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED0 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 DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the main diagonal of the tridiagonal matrix. */ +/* > On exit, its eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dlaed0_(integer *icompq, integer *qsiz, integer *n, + doublereal *d__, doublereal *e, doublereal *q, integer *ldq, + doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal temp; + integer curr, i__, j, k; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + integer iperm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer indxq, iwrem; + extern /* Subroutine */ int dlaed1_(integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer iqptr; + extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *, + integer *, integer *, integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, doublereal *, integer *, integer *); + integer tlvls, iq; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *); + integer igivcl; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer igivnm, submat, curprb, subpbs, igivpt; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer curlvl, matsiz, iprmpt, smlsiz, 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_("DLAED0", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + smlsiz = ilaenv_(&c__9, "DLAED0", " ", &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] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); +/* L40: */ + } + + indxq = (*n << 2) + 3; + if (*icompq != 2) { + +/* Set up workspaces for eigenvalues only/accumulate new vectors */ +/* routine */ + + temp = log((doublereal) (*n)) / log(2.); + 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) { + dsteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat + + submat * q_dim1], ldq, &work[1], info); + if (*info != 0) { + goto L130; + } + } else { + dsteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + + iwork[iqptr + curr]], &matsiz, &work[1], info); + if (*info != 0) { + goto L130; + } + if (*icompq == 1) { + dgemm_("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. */ +/* DLAED1 is used only for the full eigensystem of a tridiagonal */ +/* matrix. */ +/* DLAED7 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) { + dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], + ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & + msd2, &work[1], &iwork[subpbs + 1], info); + } else { + dlaed7_(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]; + dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + + 1], &c__1); +/* L100: */ + } + dcopy_(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]; + dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); +/* L110: */ + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + dlacpy_("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: */ + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + } + goto L140; + +L130: + *info = submat * (*n + 1) + submat + matsiz - 1; + +L140: + return 0; + +/* End of DLAED0 */ + +} /* dlaed0_ */ + diff --git a/lapack-netlib/SRC/dlaed1.c b/lapack-netlib/SRC/dlaed1.c new file mode 100644 index 000000000..4f31e30f1 --- /dev/null +++ b/lapack-netlib/SRC/dlaed1.c @@ -0,0 +1,691 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED1 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 DLAED1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, */ +/* INFO ) */ + +/* INTEGER CUTPNT, INFO, LDQ, N */ +/* DOUBLE PRECISION RHO */ +/* INTEGER INDXQ( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED1 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. DLAED7 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 DLAED2. */ +/* > */ +/* > The second stage consists of calculating the updated */ +/* > eigenvalues. This is done by finding the roots of the secular */ +/* > equation via the routine DLAED4 (as called by DLAED3). */ +/* > 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION 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 dlaed1_(integer *n, doublereal *d__, doublereal *q, + integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, + doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + + /* Local variables */ + integer indx, i__, k, indxc; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer indxp; + extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, integer *, integer *, integer *), dlaed3_(integer *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + doublereal *, doublereal *, integer *); + integer n1, n2, idlmda, is, iw, iz; + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + integer coltyp, iq2, zpp1; + + +/* -- 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_("DLAED1", &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 DLAED2 and DLAED3. */ + + 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. */ + + dcopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1); + zpp1 = *cutpnt + 1; + i__1 = *n - *cutpnt; + dcopy_(&i__1, &q[zpp1 + zpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1); + +/* Deflate eigenvalues. */ + + dlaed2_(&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; + dlaed3_(&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; + dlamrg_(&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 DLAED1 */ + +} /* dlaed1_ */ + diff --git a/lapack-netlib/SRC/dlaed2.c b/lapack-netlib/SRC/dlaed2.c new file mode 100644 index 000000000..c6ae91235 --- /dev/null +++ b/lapack-netlib/SRC/dlaed2.c @@ -0,0 +1,995 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED2 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 DLAED2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, */ +/* Q2, INDX, INDXC, INDXP, COLTYP, INFO ) */ + +/* INTEGER INFO, K, LDQ, N, N1 */ +/* DOUBLE PRECISION RHO */ +/* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), */ +/* $ INDXQ( * ) */ +/* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), */ +/* $ W( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED2 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 */ +/* > DLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > A copy of the first K eigenvalues which will be used by */ +/* > DLAED3 to form the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > The first k values of the final deflation-altered z-vector */ +/* > which will be passed to DLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q2 */ +/* > \verbatim */ +/* > Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) */ +/* > A copy of the first K eigenvectors which will be used by */ +/* > DLAED3 in a matrix multiply (DGEMM) 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 dlaed2_(integer *k, integer *n, integer *n1, doublereal * + d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, + doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2, + integer *indx, integer *indxc, integer *indxp, integer *coltyp, + integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer imax, jmax; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer ctot[4]; + doublereal c__; + integer i__, j; + doublereal s, t; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *); + integer k2, n2; + extern doublereal dlapy2_(doublereal *, doublereal *); + integer ct, nj; + extern doublereal dlamch_(char *); + integer pj, js; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), dlacpy_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + integer iq1, iq2, n1p1; + doublereal 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_("DLAED2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + n2 = *n - *n1; + n1p1 = *n1 + 1; + + if (*rho < 0.) { + dscal_(&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. / sqrt(2.); + dscal_(n, &t, &z__[1], &c__1); + +/* RHO = ABS( norm(z)**2 * RHO ) */ + + *rho = (d__1 = *rho * 2., abs(d__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: */ + } + dlamrg_(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 = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_("Epsilon"); +/* Computing MAX */ + d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2)) + ; + tol = eps * 8. * f2cmax(d__3,d__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 * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + iq2 = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = indx[j]; + dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + dlamda[j] = d__[i__]; + iq2 += *n; +/* L40: */ + } + dlacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq); + dcopy_(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 * (d__1 = z__[nj], abs(d__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 * (d__1 = z__[nj], abs(d__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 = dlapy2_(&c__, &s); + t = d__[nj] - d__[pj]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + +/* Deflation is possible. */ + + z__[nj] = tau; + z__[pj] = 0.; + if (coltyp[nj] != coltyp[pj]) { + coltyp[nj] = 2; + } + coltyp[pj] = 4; + drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & + c__, &s); +/* Computing 2nd power */ + d__1 = c__; +/* Computing 2nd power */ + d__2 = s; + t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); +/* Computing 2nd power */ + d__1 = s; +/* Computing 2nd power */ + d__2 = c__; + d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__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__]; + dcopy_(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__]; + dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + dcopy_(&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__]; + dcopy_(&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__]; + dcopy_(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) { + dlacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq); + i__1 = *n - *k; + dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); + } + +/* Copy CTOT into COLTYP for referencing in DLAED3. */ + + for (j = 1; j <= 4; ++j) { + coltyp[j] = ctot[j - 1]; +/* L180: */ + } + +L190: + return 0; + +/* End of DLAED2 */ + +} /* dlaed2_ */ + diff --git a/lapack-netlib/SRC/dlaed3.c b/lapack-netlib/SRC/dlaed3.c new file mode 100644 index 000000000..b669e083c --- /dev/null +++ b/lapack-netlib/SRC/dlaed3.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 DLAED3 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 DLAED3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, */ +/* CTOT, W, S, INFO ) */ + +/* INTEGER INFO, K, LDQ, N, N1 */ +/* DOUBLE PRECISION RHO */ +/* INTEGER CTOT( * ), INDX( * ) */ +/* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), */ +/* $ S( * ), W( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED3 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 DLAED4 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 */ +/* > DLAED4. 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 DOUBLE PRECISION array, dimension (N) */ +/* > D(I) contains the updated eigenvalues for */ +/* > 1 <= I <= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > The value of the parameter in the rank one update equation. */ +/* > RHO >= 0 required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DLAMDA */ +/* > \verbatim */ +/* > DLAMDA is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLAED2). */ +/* > The rows of the eigenvectors found by DLAED4 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dlaed3_(integer *k, integer *n, integer *n1, doublereal * + d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, + doublereal *q2, integer *indx, integer *ctot, doublereal *w, + doublereal *s, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal temp; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__, j; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer + *), dlaed4_(integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *); + integer n2; + extern doublereal dlamc3_(doublereal *, doublereal *); + integer n12, ii, n23; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + 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_("DLAED3", &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__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; +/* L10: */ + } + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlaed4_(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. */ + + dcopy_(k, &w[1], &c__1, &s[1], &c__1); + +/* Initialize W(I) = Q(I,I) */ + + i__1 = *ldq + 1; + dcopy_(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__) { + d__1 = sqrt(-w[i__]); + w[i__] = d_sign(&d__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 = dnrm2_(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]; + + dlacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23); + iq2 = *n1 * n12 + 1; + if (n23 != 0) { + dgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & + c_b23, &q[*n1 + 1 + q_dim1], ldq); + } else { + dlaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq); + } + + dlacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12); + if (n12 != 0) { + dgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, + &q[q_offset], ldq); + } else { + dlaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq); + } + + +L120: + return 0; + +/* End of DLAED3 */ + +} /* dlaed3_ */ + diff --git a/lapack-netlib/SRC/dlaed4.c b/lapack-netlib/SRC/dlaed4.c new file mode 100644 index 000000000..fba91a4b6 --- /dev/null +++ b/lapack-netlib/SRC/dlaed4.c @@ -0,0 +1,1379 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED4 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 DLAED4 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) */ + +/* INTEGER I, INFO, N */ +/* DOUBLE PRECISION DLAM, RHO */ +/* DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > The components of the updating vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DELTA */ +/* > \verbatim */ +/* > DELTA is DOUBLE PRECISION 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 DLAED5 */ +/* > for detail. The vector DELTA contains the information necessary */ +/* > to construct the eigenvectors by DLAED3 and DLAED9. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is DOUBLE PRECISION */ +/* > The scalar in the symmetric updating formula. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DLAM */ +/* > \verbatim */ +/* > DLAM is DOUBLE PRECISION */ +/* > 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 dlaed4_(integer *n, integer *i__, doublereal *d__, + doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam, + integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + doublereal dphi, dpsi; + integer iter; + doublereal temp, prew, temp1, a, b, c__; + integer j; + doublereal w, dltlb, dltub, midpt; + integer niter; + logical swtch; + extern /* Subroutine */ int dlaed5_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *), dlaed6_(integer *, + logical *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); + logical swtch3; + integer ii; + extern doublereal dlamch_(char *); + doublereal dw, zz[3]; + logical orgati; + doublereal erretm, rhoinv; + integer ip1; + doublereal 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.; + return 0; + } + if (*n == 2) { + dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); + return 0; + } + +/* Compute machine epsilon */ + + eps = dlamch_("Epsilon"); + rhoinv = 1. / *rho; + +/* The case I = N */ + + if (*i__ == *n) { + +/* Initialize some basic variables */ + + ii = *n - 1; + niter = 1; + +/* Calculate initial guess */ + + midpt = *rho / 2.; + +/* 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.; + 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.) { + 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.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + } + +/* 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.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + +/* It can be proved that */ +/* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */ + + dltlb = 0.; + 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.; + psi = 0.; + erretm = 0.; + 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. + 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.) { + 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.) { + c__ = abs(c__); + } + if (c__ == 0.) { +/* ETA = B/A */ +/* ETA = RHO - TAU */ + eta = dltub - tau; + } else if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__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.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L50: */ + } + + tau += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + 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. + 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.) { + 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.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( + d__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.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L70: */ + } + + tau += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + 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. + 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.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; +/* L100: */ + } + + psi = 0.; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; +/* L110: */ + } + + phi = 0.; + 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.) { + +/* 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.) { + tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } else { + tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } + dltlb = 0.; + 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.) { + tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( + d__1)))); + } else { + tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } + dltlb = -midpt; + dltub = 0.; + } + + 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.; + psi = 0.; + erretm = 0.; + 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.; + phi = 0.; + 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.) { + swtch3 = TRUE_; + } + } else { + if (w > 0.) { + 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. + erretm + rhoinv * 2. + abs(temp) * 3. + + 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.) { + dltlb = f2cmax(dltlb,tau); + } else { + dltub = f2cmin(dltub,tau); + } + +/* Calculate the new step */ + + ++niter; + if (! swtch3) { + if (orgati) { +/* Computing 2nd power */ + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * + d__1); + } else { +/* Computing 2nd power */ + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * + d__1); + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * + dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.) { + if (a == 0.) { + 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.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__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]; + dlaed6_(&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.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + + prew = w; + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L180: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + 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.; + phi = 0.; + 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. + erretm + rhoinv * 2. + abs(temp) * 3. + ( + d__1 = tau + eta, abs(d__1)) * dw; + + swtch = FALSE_; + if (orgati) { + if (-w > abs(prew) / 10.) { + swtch = TRUE_; + } + } else { + if (w > abs(prew) / 10.) { + 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.) { + dltlb = f2cmax(dltlb,tau); + } else { + dltub = f2cmin(dltub,tau); + } + +/* Calculate the new step */ + + if (! swtch3) { + if (! swtch) { + if (orgati) { +/* Computing 2nd power */ + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * ( + d__1 * d__1); + } else { +/* Computing 2nd power */ + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * + (d__1 * d__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.) { + if (a == 0.) { + 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.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) + / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, + abs(d__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]; + } + } + dlaed6_(&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.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + + 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.; + psi = 0.; + erretm = 0.; + 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.; + phi = 0.; + 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. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + 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 DLAED4 */ + +} /* dlaed4_ */ + diff --git a/lapack-netlib/SRC/dlaed5.c b/lapack-netlib/SRC/dlaed5.c new file mode 100644 index 000000000..7844058e5 --- /dev/null +++ b/lapack-netlib/SRC/dlaed5.c @@ -0,0 +1,572 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED5 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 DLAED5 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) */ + +/* INTEGER I */ +/* DOUBLE PRECISION DLAM, RHO */ +/* DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (2) */ +/* > The original eigenvalues. We assume D(1) < D(2). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (2) */ +/* > The components of the updating vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DELTA */ +/* > \verbatim */ +/* > DELTA is DOUBLE PRECISION array, dimension (2) */ +/* > The vector DELTA contains the information necessary */ +/* > to construct the eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is DOUBLE PRECISION */ +/* > The scalar in the symmetric updating formula. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DLAM */ +/* > \verbatim */ +/* > DLAM is DOUBLE PRECISION */ +/* > 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 dlaed5_(integer *i__, doublereal *d__, doublereal *z__, + doublereal *delta, doublereal *rho, doublereal *dlam) +{ + /* System generated locals */ + doublereal d__1; + + /* Local variables */ + doublereal 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. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.; + if (w > 0.) { + b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * del; + +/* B > ZERO, always */ + + tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__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.) { + tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); + } else { + tau = (b - sqrt(b * b + c__ * 4.)) / 2.; + } + *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.) { + tau = (b + sqrt(b * b + c__ * 4.)) / 2.; + } else { + tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); + } + *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 DLAED5 */ + +} /* dlaed5_ */ + diff --git a/lapack-netlib/SRC/dlaed6.c b/lapack-netlib/SRC/dlaed6.c new file mode 100644 index 000000000..0c76faa4a --- /dev/null +++ b/lapack-netlib/SRC/dlaed6.c @@ -0,0 +1,812 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED6 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 DLAED6 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) */ + +/* LOGICAL ORGATI */ +/* INTEGER INFO, KNITER */ +/* DOUBLE PRECISION FINIT, RHO, TAU */ +/* DOUBLE PRECISION D( 3 ), Z( 3 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED6 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 DLAED4 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 DLAED4 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 */ +/* > DLAED4 for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is DOUBLE PRECISION */ +/* > Refer to the equation f(x) above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (3) */ +/* > D satisfies d(1) < d(2) < d(3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (3) */ +/* > Each of the elements in z must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] FINIT */ +/* > \verbatim */ +/* > FINIT is DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 dlaed6_(integer *kniter, logical *orgati, doublereal * + rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal * + tau, integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal base; + integer iter; + doublereal temp, temp1, temp2, temp3, temp4, a, b, c__, f; + integer i__; + logical scale; + integer niter; + doublereal small1, small2, fc, df, sminv1, sminv2; + extern doublereal dlamch_(char *); + doublereal dscale[3], sclfac, 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.) { + lbd = 0.; + } else { + ubd = 0.; + } + + niter = 1; + *tau = 0.; + if (*kniter == 2) { + if (*orgati) { + temp = (d__[3] - d__[2]) / 2.; + 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.; + 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 */ + d__1 = abs(a), d__2 = abs(b), d__1 = f2cmax(d__1,d__2), d__2 = abs(c__); + temp = f2cmax(d__1,d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + *tau = b / a; + } else if (a <= 0.) { + *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)) + )); + } + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } + if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { + *tau = 0.; + } 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.) { + lbd = *tau; + } else { + ubd = *tau; + } + if (abs(*finit) <= abs(temp)) { + *tau = 0.; + } + } + } + +/* 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 = dlamch_("Epsilon"); + base = dlamch_("Base"); + i__1 = (integer) (log(dlamch_("SafMin")) / log(base) / 3.); + small1 = pow_di(&base, &i__1); + sminv1 = 1. / 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 */ + d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - * + tau, abs(d__2)); + temp = f2cmin(d__3,d__4); + } else { +/* Computing MIN */ + d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - * + tau, abs(d__2)); + temp = f2cmin(d__3,d__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.; + df = 0.; + ddf = 0.; + for (i__ = 1; i__ <= 3; ++i__) { + temp = 1. / (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.) { + goto L60; + } + if (f <= 0.) { + 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 */ + d__1 = abs(a), d__2 = abs(b), d__1 = f2cmax(d__1,d__2), d__2 = abs(c__); + temp = f2cmax(d__1,d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) + ); + } + if (f * eta >= 0.) { + eta = -f / df; + } + + *tau += eta; + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } + + fc = 0.; + erretm = 0.; + df = 0.; + ddf = 0.; + for (i__ = 1; i__ <= 3; ++i__) { + if (dscale[i__ - 1] - *tau != 0.) { + temp = 1. / (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. + abs(*tau) * df; + if (abs(f) <= eps * 4. * erretm || ubd - lbd <= eps * 4. * abs(*tau)) + { + goto L60; + } + if (f <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } +/* L50: */ + } + *info = 1; +L60: + +/* Undo scaling */ + + if (scale) { + *tau *= sclinv; + } + return 0; + +/* End of DLAED6 */ + +} /* dlaed6_ */ + diff --git a/lapack-netlib/SRC/dlaed7.c b/lapack-netlib/SRC/dlaed7.c new file mode 100644 index 000000000..b049202d7 --- /dev/null +++ b/lapack-netlib/SRC/dlaed7.c @@ -0,0 +1,832 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED7 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 DLAED7 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED7( 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 */ +/* DOUBLE PRECISION RHO */ +/* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), */ +/* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) */ +/* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), */ +/* $ QSTORE( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED7 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. DLAED1 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 DLAED8. */ +/* > */ +/* > The second stage consists of calculating the updated */ +/* > eigenvalues. This is done by finding the roots of the secular */ +/* > equation via the routine DLAED4 (as called by DLAED9). */ +/* > 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dlaed7_(integer *icompq, integer *n, integer *qsiz, + integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, + doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer + *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer * + perm, integer *givptr, integer *givcol, doublereal *givnum, + doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + + /* Local variables */ + integer indx, curr, i__, k; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + integer indxc, indxp, n1, n2; + extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *), dlaed9_(integer *, + integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, integer *), dlaeda_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, doublereal *, integer *, doublereal *, doublereal *, integer *) + ; + integer idlmda, is, iw, iz; + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + 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_("DLAED7", &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 DLAED8 and DLAED9. */ + + 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; + dlaeda_(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. */ + + dlaed8_(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) { + dlaed9_(&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) { + dgemm_("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; + dlamrg_(&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 DLAED7 */ + +} /* dlaed7_ */ + diff --git a/lapack-netlib/SRC/dlaed8.c b/lapack-netlib/SRC/dlaed8.c new file mode 100644 index 000000000..625cfe63e --- /dev/null +++ b/lapack-netlib/SRC/dlaed8.c @@ -0,0 +1,959 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED8 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 DLAED8 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED8( 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 */ +/* DOUBLE PRECISION RHO */ +/* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), */ +/* $ INDXQ( * ), PERM( * ) */ +/* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), */ +/* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED8 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 */ +/* > DLAED3. */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > A copy of the first K eigenvalues which will be used by */ +/* > DLAED3 to form the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q2 */ +/* > \verbatim */ +/* > Q2 is DOUBLE PRECISION array, dimension (LDQ2,N) */ +/* > If ICOMPQ = 0, Q2 is not referenced. Otherwise, */ +/* > a copy of the first K eigenvectors which will be used by */ +/* > DLAED7 in a matrix multiply (DGEMM) 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 DOUBLE PRECISION array, dimension (N) */ +/* > The first k values of the final deflation-altered z-vector and */ +/* > will be passed to DLAED3. */ +/* > \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 DOUBLE PRECISION 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 dlaed8_(integer *icompq, integer *k, integer *n, integer + *qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, + doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda, + doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer + *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer + *indx, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer jlam, imax, jmax; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + doublereal c__; + integer i__, j; + doublereal s, t; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *); + integer k2, n1, n2; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); + integer jp; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), dlacpy_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + integer n1p1; + doublereal 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_("DLAED8", &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.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + +/* Normalize z so that norm(z) = 1 */ + + t = 1. / sqrt(2.); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; +/* L10: */ + } + dscal_(n, &t, &z__[1], &c__1); + *rho = (d__1 = *rho * 2., abs(d__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; + dlamrg_(&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 = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_("Epsilon"); + tol = eps * 8. * (d__1 = d__[jmax], abs(d__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 * (d__1 = z__[imax], abs(d__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]]; + dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + + 1], &c__1); +/* L60: */ + } + dlacpy_("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 * (d__1 = z__[j], abs(d__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 * (d__1 = z__[j], abs(d__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 = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + +/* Deflation is possible. */ + + z__[j] = tau; + z__[jlam] = 0.; + +/* 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) { + drot_(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]]; + dcopy_(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; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + } else { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + dlacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* + k + 1) * q_dim1 + 1], ldq); + } + } + + return 0; + +/* End of DLAED8 */ + +} /* dlaed8_ */ + diff --git a/lapack-netlib/SRC/dlaed9.c b/lapack-netlib/SRC/dlaed9.c new file mode 100644 index 000000000..16763ea98 --- /dev/null +++ b/lapack-netlib/SRC/dlaed9.c @@ -0,0 +1,721 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAED9 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 DLAED9 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, */ +/* S, LDS, INFO ) */ + +/* INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N */ +/* DOUBLE PRECISION RHO */ +/* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), */ +/* $ W( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAED9 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 DLAED4 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 */ +/* > DLAED4. 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 DOUBLE PRECISION array, dimension (N) */ +/* > D(I) contains the updated eigenvalues */ +/* > for KSTART <= I <= KSTOP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > The value of the parameter in the rank one update equation. */ +/* > RHO >= 0 required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DLAMDA */ +/* > \verbatim */ +/* > DLAMDA is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dlaed9_(integer *k, integer *kstart, integer *kstop, + integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal * + rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, + integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal temp; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__, j; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dlaed4_(integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); + extern doublereal dlamc3_(doublereal *, doublereal *); + 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_("DLAED9", &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__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; +/* L10: */ + } + + i__1 = *kstop; + for (j = *kstart; j <= i__1; ++j) { + dlaed4_(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. */ + + dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1); + +/* Initialize W(I) = Q(I,I) */ + + i__1 = *ldq + 1; + dcopy_(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__) { + d__1 = sqrt(-w[i__]); + w[i__] = d_sign(&d__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 = dnrm2_(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 DLAED9 */ + +} /* dlaed9_ */ + diff --git a/lapack-netlib/SRC/dlaeda.c b/lapack-netlib/SRC/dlaeda.c new file mode 100644 index 000000000..b1b89c906 --- /dev/null +++ b/lapack-netlib/SRC/dlaeda.c @@ -0,0 +1,735 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAEDA 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 DLAEDA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAEDA( 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( * ) */ +/* DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAEDA 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, + integer *curpbm, integer *prmptr, integer *perm, integer *givptr, + integer *givcol, doublereal *givnum, doublereal *q, integer *qptr, + doublereal *z__, doublereal *ztemp, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer curr, bsiz1, bsiz2, psiz1, psiz2, i__, k, zptr1; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, 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_("DLAEDA", &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((doublereal) (qptr[curr + 1] - qptr[curr])) + .5); + bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) + + .5); + i__1 = mid - bsiz1 - 1; + for (k = 1; k <= i__1; ++k) { + z__[k] = 0.; +/* L10: */ + } + dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], & + c__1); + dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); + i__1 = *n; + for (k = mid + bsiz2; k <= i__1; ++k) { + z__[k] = 0.; +/* 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__) { + drot_(&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__) { + drot_(&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((doublereal) (qptr[curr + 1] - qptr[curr])) + + .5); + bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1]) + ) + .5); + if (bsiz1 > 0) { + dgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & + ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1); + } + i__2 = psiz1 - bsiz1; + dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); + if (bsiz2 > 0) { + dgemv_("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; + dcopy_(&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 DLAEDA */ + +} /* dlaeda_ */ + diff --git a/lapack-netlib/SRC/dlaein.c b/lapack-netlib/SRC/dlaein.c new file mode 100644 index 000000000..7599236b8 --- /dev/null +++ b/lapack-netlib/SRC/dlaein.c @@ -0,0 +1,1136 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAEIN 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 DLAEIN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, */ +/* LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) */ + +/* LOGICAL NOINIT, RIGHTV */ +/* INTEGER INFO, LDB, LDH, N */ +/* DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR */ +/* DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAEIN 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WI */ +/* > \verbatim */ +/* > WI is DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VI */ +/* > \verbatim */ +/* > VI is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EPS3 */ +/* > \verbatim */ +/* > EPS3 is DOUBLE PRECISION */ +/* > A small machine-dependent value which is used to perturb */ +/* > close eigenvalues, and to replace zero pivots. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLNUM */ +/* > \verbatim */ +/* > SMLNUM is DOUBLE PRECISION */ +/* > A machine-dependent value close to the underflow threshold. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BIGNUM */ +/* > \verbatim */ +/* > BIGNUM is DOUBLE PRECISION */ +/* > 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlaein_(logical *rightv, logical *noinit, integer *n, + doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, + doublereal *vr, doublereal *vi, doublereal *b, integer *ldb, + doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal * + bignum, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer ierr; + doublereal temp, norm, vmax; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal scale, w, x, y; + extern doublereal dasum_(integer *, doublereal *, integer *); + char trans[1]; + doublereal vcrit; + integer i1, i2, i3; + doublereal rootn, vnorm, w1; + extern doublereal dlapy2_(doublereal *, doublereal *); + doublereal ei, ej, absbii, absbjj, xi; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + doublereal xr; + extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *); + char normin[1]; + doublereal nrmsml, 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((doublereal) (*n)); + growto = .1 / rootn; +/* Computing MAX */ + d__1 = 1., d__2 = *eps3 * rootn; + nrmsml = f2cmax(d__1,d__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.) { + +/* 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 = dnrm2_(n, &vr[1], &c__1); + d__1 = *eps3 * rootn / f2cmax(vnorm,nrmsml); + dscal_(n, &d__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 ((d__1 = b[i__ + i__ * b_dim1], abs(d__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.) { + b[i__ + i__ * b_dim1] = *eps3; + } + x = ei / b[i__ + i__ * b_dim1]; + if (x != 0.) { + 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.) { + 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 ((d__1 = b[j + j * b_dim1], abs(d__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.) { + b[j + j * b_dim1] = *eps3; + } + x = ej / b[j + j * b_dim1]; + if (x != 0.) { + 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.) { + 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. */ + + dlatrs_("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 = dasum_(n, &vr[1], &c__1); + if (vnorm >= growto * scale) { + goto L120; + } + +/* Choose new orthogonal starting vector and try again. */ + + temp = *eps3 / (rootn + 1.); + 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__ = idamax_(n, &vr[1], &c__1); + d__2 = 1. / (d__1 = vr[i__], abs(d__1)); + dscal_(n, &d__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.; +/* L130: */ + } + } else { + +/* Scale supplied initial vector. */ + + d__1 = dnrm2_(n, &vr[1], &c__1); + d__2 = dnrm2_(n, &vi[1], &c__1); + norm = dlapy2_(&d__1, &d__2); + rec = *eps3 * rootn / f2cmax(norm,nrmsml); + dscal_(n, &rec, &vr[1], &c__1); + dscal_(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.; +/* L140: */ + } + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + absbii = dlapy2_(&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.; + 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.; +/* 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.) { + b[i__ + i__ * b_dim1] = *eps3; + b[i__ + 1 + i__ * b_dim1] = 0.; + 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__] = dasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) + + dasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1); +/* L170: */ + } + if (b[*n + *n * b_dim1] == 0. && b[*n + 1 + *n * b_dim1] == 0.) { + b[*n + *n * b_dim1] = *eps3; + } + work[*n] = 0.; + + 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.; +/* L180: */ + } + + for (j = *n; j >= 2; --j) { + ej = h__[j + (j - 1) * h_dim1]; + absbjj = dlapy2_(&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.; + 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.; +/* 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.) { + b[j + j * b_dim1] = *eps3; + b[j + 1 + j * b_dim1] = 0.; + 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] = dasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + dasum_(& + i__2, &b[j + 1 + b_dim1], ldb); +/* L210: */ + } + if (b[b_dim1 + 1] == 0. && b[b_dim1 + 2] == 0.) { + b[b_dim1 + 1] = *eps3; + } + work[1] = 0.; + + i1 = 1; + i2 = *n; + i3 = 1; + } + + i__1 = *n; + for (its = 1; its <= i__1; ++its) { + scale = 1.; + vmax = 1.; + 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. / vmax; + dscal_(n, &rec, &vr[1], &c__1); + dscal_(n, &rec, &vi[1], &c__1); + scale *= rec; + vmax = 1.; + 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 = (d__1 = b[i__ + i__ * b_dim1], abs(d__1)) + (d__2 = b[i__ + + 1 + i__ * b_dim1], abs(d__2)); + if (w > *smlnum) { + if (w < 1.) { + w1 = abs(xr) + abs(xi); + if (w1 > w * *bignum) { + rec = 1. / w1; + dscal_(n, &rec, &vr[1], &c__1); + dscal_(n, &rec, &vi[1], &c__1); + xr = vr[i__]; + xi = vi[i__]; + scale *= rec; + vmax *= rec; + } + } + +/* Divide by diagonal element of B. */ + + dladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + + i__ * b_dim1], &vr[i__], &vi[i__]); +/* Computing MAX */ + d__3 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__], abs( + d__2)); + vmax = f2cmax(d__3,vmax); + vcrit = *bignum / vmax; + } else { + i__4 = *n; + for (j = 1; j <= i__4; ++j) { + vr[j] = 0.; + vi[j] = 0.; +/* L240: */ + } + vr[i__] = 1.; + vi[i__] = 1.; + scale = 0.; + vmax = 1.; + vcrit = *bignum; + } +/* L250: */ + } + +/* Test for sufficient growth in the norm of (VR,VI). */ + + vnorm = dasum_(n, &vr[1], &c__1) + dasum_(n, &vi[1], &c__1); + if (vnorm >= growto * scale) { + goto L280; + } + +/* Choose a new orthogonal starting vector and try again. */ + + y = *eps3 / (rootn + 1.); + vr[1] = *eps3; + vi[1] = 0.; + + i__3 = *n; + for (i__ = 2; i__ <= i__3; ++i__) { + vr[i__] = y; + vi[i__] = 0.; +/* L260: */ + } + vr[*n - its + 1] -= *eps3 * rootn; +/* L270: */ + } + +/* Failure to find eigenvector in N iterations */ + + *info = 1; + +L280: + +/* Normalize eigenvector. */ + + vnorm = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__3 = vnorm, d__4 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__] + , abs(d__2)); + vnorm = f2cmax(d__3,d__4); +/* L290: */ + } + d__1 = 1. / vnorm; + dscal_(n, &d__1, &vr[1], &c__1); + d__1 = 1. / vnorm; + dscal_(n, &d__1, &vi[1], &c__1); + + } + + return 0; + +/* End of DLAEIN */ + +} /* dlaein_ */ + diff --git a/lapack-netlib/SRC/dlaev2.c b/lapack-netlib/SRC/dlaev2.c new file mode 100644 index 000000000..53bdce128 --- /dev/null +++ b/lapack-netlib/SRC/dlaev2.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 DLAEV2 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 DLAEV2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) */ + +/* DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAEV2 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 DOUBLE PRECISION */ +/* > The (1,1) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > The (2,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1 */ +/* > \verbatim */ +/* > RT1 is DOUBLE PRECISION */ +/* > The eigenvalue of larger absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2 */ +/* > \verbatim */ +/* > RT2 is DOUBLE PRECISION */ +/* > The eigenvalue of smaller absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS1 */ +/* > \verbatim */ +/* > CS1 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN1 */ +/* > \verbatim */ +/* > SN1 is DOUBLE PRECISION */ +/* > 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 dlaev2_(doublereal *a, doublereal *b, doublereal *c__, + doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1) +{ + /* System generated locals */ + doublereal d__1; + + /* Local variables */ + doublereal 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 */ + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); + } else if (adf < ab) { +/* Computing 2nd power */ + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); + } else { + +/* Includes case AB=ADF=0 */ + + rt = ab * sqrt(2.); + } + if (sm < 0.) { + *rt1 = (sm - rt) * .5; + 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.) { + *rt1 = (sm + rt) * .5; + 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 * .5; + *rt2 = rt * -.5; + sgn1 = 1; + } + +/* Compute the eigenvector */ + + if (df >= 0.) { + cs = df + rt; + sgn2 = 1; + } else { + cs = df - rt; + sgn2 = -1; + } + acs = abs(cs); + if (acs > ab) { + ct = -tb / cs; + *sn1 = 1. / sqrt(ct * ct + 1.); + *cs1 = ct * *sn1; + } else { + if (ab == 0.) { + *cs1 = 1.; + *sn1 = 0.; + } else { + tn = -cs / tb; + *cs1 = 1. / sqrt(tn * tn + 1.); + *sn1 = tn * *cs1; + } + } + if (sgn1 == sgn2) { + tn = *cs1; + *cs1 = -(*sn1); + *sn1 = tn; + } + return 0; + +/* End of DLAEV2 */ + +} /* dlaev2_ */ + diff --git a/lapack-netlib/SRC/dlaexc.c b/lapack-netlib/SRC/dlaexc.c new file mode 100644 index 000000000..c874b131a --- /dev/null +++ b/lapack-netlib/SRC/dlaexc.c @@ -0,0 +1,900 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAEXC 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 DLAEXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, */ +/* INFO ) */ + +/* LOGICAL WANTQ */ +/* INTEGER INFO, J1, LDQ, LDT, N, N1, N2 */ +/* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAEXC 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t, + integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1, + integer *n2, doublereal *work, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer ierr; + doublereal temp; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + doublereal d__[16] /* was [4][4] */; + integer k; + doublereal u[3], scale, x[4] /* was [2][2] */, dnorm; + integer j2, j3, j4; + doublereal xnorm, u1[3], u2[3]; + extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_( + logical *, logical *, integer *, integer *, integer *, doublereal + *, integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer nd; + doublereal cs, t11, t22; + extern doublereal dlamch_(char *); + doublereal t33; + extern doublereal dlange_(char *, integer *, integer *, doublereal *, + integer *, doublereal *); + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *); + doublereal sn; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), dlarfx_(char *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *); + doublereal thresh, 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. */ + + d__1 = t22 - t11; + dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp); + +/* Apply transformation to the matrix T. */ + + if (j3 <= *n) { + i__1 = *n - *j1 - 1; + drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1], + ldt, &cs, &sn); + } + i__1 = *j1 - 1; + drot_(&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. */ + + drot_(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; + dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4); + dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]); + +/* Compute machine-dependent threshold for test for accepting */ +/* swap. */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; +/* Computing MAX */ + d__1 = eps * 10. * dnorm; + thresh = f2cmax(d__1,smlnum); + +/* Solve T11*X - X*T22 = scale*T12 for X. */ + + dlasy2_(&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]; + dlarfg_(&c__3, &u[2], u, &c__1, &tau); + u[2] = 1.; + t11 = t[*j1 + *j1 * t_dim1]; + +/* Perform swap provisionally on diagonal block in D. */ + + dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = f2cmax(d__2,d__3), d__3 = + (d__1 = d__[10] - t11, abs(d__1)); + if (f2cmax(d__2,d__3) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); + + t[j3 + *j1 * t_dim1] = 0.; + t[j3 + j2 * t_dim1] = 0.; + t[j3 + j3 * t_dim1] = t11; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + dlarfx_("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; + dlarfg_(&c__3, u, &u[1], &c__1, &tau); + u[0] = 1.; + t33 = t[j3 + j3 * t_dim1]; + +/* Perform swap provisionally on diagonal block in D. */ + + dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = f2cmax(d__2,d__3), d__3 = + (d__1 = d__[0] - t33, abs(d__1)); + if (f2cmax(d__2,d__3) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); + i__1 = *n - *j1; + dlarfx_("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.; + t[j3 + *j1 * t_dim1] = 0.; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + dlarfx_("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; + dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1); + u1[0] = 1.; + + temp = -tau1 * (x[2] + u1[1] * x[3]); + u2[0] = -temp * u1[1] - x[3]; + u2[1] = -temp * u1[2]; + u2[2] = scale; + dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2); + u2[0] = 1.; + +/* Perform swap provisionally on diagonal block in D. */ + + dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1]) + ; + dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1]) + ; + dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]); + dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = f2cmax(d__1,d__2), d__2 = + abs(d__[3]), d__1 = f2cmax(d__1,d__2), d__2 = abs(d__[7]); + if (f2cmax(d__1,d__2) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[ + 1]); + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1] + ); + + t[j3 + *j1 * t_dim1] = 0.; + t[j3 + j2 * t_dim1] = 0.; + t[j4 + *j1 * t_dim1] = 0.; + t[j4 + j2 * t_dim1] = 0.; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, & + work[1]); + dlarfx_("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 */ + + dlanv2_(&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; + drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2) + * t_dim1], ldt, &cs, &sn); + i__1 = *j1 - 1; + drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + drot_(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; + dlanv2_(&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; + drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2) + * t_dim1], ldt, &cs, &sn); + } + i__1 = j3 - 1; + drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + drot_(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 DLAEXC */ + +} /* dlaexc_ */ + diff --git a/lapack-netlib/SRC/dlag2.c b/lapack-netlib/SRC/dlag2.c new file mode 100644 index 000000000..917505fcf --- /dev/null +++ b/lapack-netlib/SRC/dlag2.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 DLAG2 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 DLAG2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, */ +/* WR2, WI ) */ + +/* INTEGER LDA, LDB */ +/* DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAG2 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > The smallest positive number s.t. 1/SAFMIN does not */ +/* > overflow. (This should always be DLAMCH('S') -- it is an */ +/* > argument in order to avoid having to call DLAMCH frequently.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE1 */ +/* > \verbatim */ +/* > SCALE1 is DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlag2_(doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *safmin, doublereal *scale1, doublereal * + scale2, doublereal *wr1, doublereal *wr2, doublereal *wi) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + doublereal 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. / rtmin; + safmax = 1. / *safmin; + +/* Scale A */ + +/* Computing MAX */ + d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs( + d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 = + a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = f2cmax(d__5,d__6); + anorm = f2cmax(d__5,*safmin); + ascale = 1. / 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 */ + d__1 = abs(b11), d__2 = abs(b12), d__1 = f2cmax(d__1,d__2), d__2 = abs(b22), + d__1 = f2cmax(d__1,d__2); + bmin = rtmin * f2cmax(d__1,rtmin); + if (abs(b11) < bmin) { + b11 = d_sign(&bmin, &b11); + } + if (abs(b22) < bmin) { + b22 = d_sign(&bmin, &b22); + } + +/* Scale B */ + +/* Computing MAX */ + d__1 = abs(b11), d__2 = abs(b12) + abs(b22), d__1 = f2cmax(d__1,d__2); + bnorm = f2cmax(d__1,*safmin); +/* Computing MAX */ + d__1 = abs(b11), d__2 = abs(b22); + bsize = f2cmax(d__1,d__2); + bscale = 1. / 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. / b11; + binv22 = 1. / 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 * .5; + shift = s1; + } else { + as12 = a12 - s2 * b12; + as11 = a11 - s2 * b11; + ss = a21 * (binv11 * binv22); + abi22 = -ss * b12; + pp = (as11 * binv11 + abi22) * .5; + shift = s2; + } + qq = ss * as12; + if ((d__1 = pp * rtmin, abs(d__1)) >= 1.) { +/* Computing 2nd power */ + d__1 = rtmin * pp; + discr = d__1 * d__1 + qq * *safmin; + r__ = sqrt((abs(discr))) * rtmax; + } else { +/* Computing 2nd power */ + d__1 = pp; + if (d__1 * d__1 + abs(qq) <= *safmin) { +/* Computing 2nd power */ + d__1 = rtmax * pp; + discr = d__1 * d__1 + qq * safmax; + r__ = sqrt((abs(discr))) * rtmin; + } else { +/* Computing 2nd power */ + d__1 = pp; + discr = d__1 * d__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. || r__ == 0.) { + sum = pp + d_sign(&r__, &pp); + diff = pp - d_sign(&r__, &pp); + wbig = shift + sum; + +/* Compute smaller eigenvalue */ + + wsmall = shift + diff; +/* Computing MAX */ + d__1 = abs(wsmall); + if (abs(wbig) * .5 > f2cmax(d__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.; + } 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.,ascale)); + c2 = *safmin * f2cmax(1.,bnorm); + c3 = bsize * *safmin; + if (ascale <= 1. && bsize <= 1.) { +/* Computing MIN */ + d__1 = 1., d__2 = ascale / *safmin * bsize; + c4 = f2cmin(d__1,d__2); + } else { + c4 = 1.; + } + if (ascale <= 1. || bsize <= 1.) { +/* Computing MIN */ + d__1 = 1., d__2 = ascale * bsize; + c5 = f2cmin(d__1,d__2); + } else { + c5 = 1.; + } + +/* Scale first eigenvalue */ + + wabs = abs(*wr1) + abs(*wi); +/* Computing MAX */ +/* Computing MIN */ + d__3 = c4, d__4 = f2cmax(wabs,c5) * .5; + d__1 = f2cmax(*safmin,c1), d__2 = (wabs * c2 + c3) * 1.0000100000000001, + d__1 = f2cmax(d__1,d__2), d__2 = f2cmin(d__3,d__4); + wsize = f2cmax(d__1,d__2); + if (wsize != 1.) { + wscale = 1. / wsize; + if (wsize > 1.) { + *scale1 = f2cmax(ascale,bsize) * wscale * f2cmin(ascale,bsize); + } else { + *scale1 = f2cmin(ascale,bsize) * wscale * f2cmax(ascale,bsize); + } + *wr1 *= wscale; + if (*wi != 0.) { + *wi *= wscale; + *wr2 = *wr1; + *scale2 = *scale1; + } + } else { + *scale1 = ascale * bsize; + *scale2 = *scale1; + } + +/* Scale second eigenvalue (if real) */ + + if (*wi == 0.) { +/* Computing MAX */ +/* Computing MIN */ +/* Computing MAX */ + d__5 = abs(*wr2); + d__3 = c4, d__4 = f2cmax(d__5,c5) * .5; + d__1 = f2cmax(*safmin,c1), d__2 = (abs(*wr2) * c2 + c3) * + 1.0000100000000001, d__1 = f2cmax(d__1,d__2), d__2 = f2cmin(d__3, + d__4); + wsize = f2cmax(d__1,d__2); + if (wsize != 1.) { + wscale = 1. / wsize; + if (wsize > 1.) { + *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 DLAG2 */ + + return 0; +} /* dlag2_ */ + diff --git a/lapack-netlib/SRC/dlag2s.c b/lapack-netlib/SRC/dlag2s.c new file mode 100644 index 000000000..f3a7117e3 --- /dev/null +++ b/lapack-netlib/SRC/dlag2s.c @@ -0,0 +1,547 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAG2S converts a double precision matrix to a single precision matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLAG2S + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) */ + +/* INTEGER INFO, LDA, LDSA, M, N */ +/* REAL SA( LDSA, * ) */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE */ +/* > PRECISION matrix, A. */ +/* > */ +/* > RMAX is the overflow for the SINGLE PRECISION arithmetic */ +/* > DLAG2S checks that all the entries of A are between -RMAX and */ +/* > RMAX. If not the conversion is aborted and a flag is raised. */ +/* > */ +/* > 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] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, 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] SA */ +/* > \verbatim */ +/* > SA is REAL array, dimension (LDSA,N) */ +/* > On exit, if INFO=0, the M-by-N coefficient matrix SA; if */ +/* > INFO>0, the content of SA is unspecified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDSA */ +/* > \verbatim */ +/* > LDSA is INTEGER */ +/* > The leading dimension of the array SA. LDSA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > = 1: an entry of the matrix A is greater than the SINGLE */ +/* > PRECISION overflow threshold, in this case, the content */ +/* > of SA in exit is unspecified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlag2s_(integer *m, integer *n, doublereal *a, integer * + lda, real *sa, integer *ldsa, integer *info) +{ + /* System generated locals */ + integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + doublereal rmax; + integer i__, j; + extern real slamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + sa_dim1 = *ldsa; + sa_offset = 1 + sa_dim1 * 1; + sa -= sa_offset; + + /* Function Body */ + rmax = slamch_("O"); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) { + *info = 1; + goto L30; + } + sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + *info = 0; +L30: + return 0; + +/* End of DLAG2S */ + +} /* dlag2s_ */ + diff --git a/lapack-netlib/SRC/dlags2.c b/lapack-netlib/SRC/dlags2.c new file mode 100644 index 000000000..b4e293ed7 --- /dev/null +++ b/lapack-netlib/SRC/dlags2.c @@ -0,0 +1,751 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAGS2 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 DLAGS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, */ +/* SNV, CSQ, SNQ ) */ + +/* LOGICAL UPPER */ +/* DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, */ +/* $ SNU, SNV */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAGS2 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 DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A2 */ +/* > \verbatim */ +/* > A2 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A3 */ +/* > \verbatim */ +/* > A3 is DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B2 */ +/* > \verbatim */ +/* > B2 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B3 */ +/* > \verbatim */ +/* > B3 is DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNU */ +/* > \verbatim */ +/* > SNU is DOUBLE PRECISION */ +/* > The desired orthogonal matrix U. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSV */ +/* > \verbatim */ +/* > CSV is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNV */ +/* > \verbatim */ +/* > SNV is DOUBLE PRECISION */ +/* > The desired orthogonal matrix V. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSQ */ +/* > \verbatim */ +/* > CSQ is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNQ */ +/* > \verbatim */ +/* > SNQ is DOUBLE PRECISION */ +/* > 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlags2_(logical *upper, doublereal *a1, doublereal *a2, + doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3, + doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv, + doublereal *csq, doublereal *snq) +{ + /* System generated locals */ + doublereal d__1; + + /* Local variables */ + doublereal aua11, aua12, aua21, aua22, avb11, avb12, avb21, avb22, ua11r, + ua22r, vb11r, vb22r, a, b, c__, d__, r__, s1, s2; + extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *), dlartg_(doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + doublereal 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 ) */ + + dlasv2_(&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.) { + if (aua12 / (abs(ua11r) + abs(ua12)) <= avb12 / (abs(vb11r) + + abs(vb12))) { + d__1 = -ua11r; + dlartg_(&d__1, &ua12, csq, snq, &r__); + } else { + d__1 = -vb11r; + dlartg_(&d__1, &vb12, csq, snq, &r__); + } + } else { + d__1 = -vb11r; + dlartg_(&d__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.) { + if (aua22 / (abs(ua21) + abs(ua22)) <= avb22 / (abs(vb21) + + abs(vb22))) { + d__1 = -ua21; + dlartg_(&d__1, &ua22, csq, snq, &r__); + } else { + d__1 = -vb21; + dlartg_(&d__1, &vb22, csq, snq, &r__); + } + } else { + d__1 = -vb21; + dlartg_(&d__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 ) */ + + dlasv2_(&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.) { + if (aua21 / (abs(ua21) + abs(ua22r)) <= avb21 / (abs(vb21) + + abs(vb22r))) { + dlartg_(&ua22r, &ua21, csq, snq, &r__); + } else { + dlartg_(&vb22r, &vb21, csq, snq, &r__); + } + } else { + dlartg_(&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.) { + if (aua11 / (abs(ua11) + abs(ua12)) <= avb11 / (abs(vb11) + + abs(vb12))) { + dlartg_(&ua12, &ua11, csq, snq, &r__); + } else { + dlartg_(&vb12, &vb11, csq, snq, &r__); + } + } else { + dlartg_(&vb12, &vb11, csq, snq, &r__); + } + + *csu = snr; + *snu = csr; + *csv = snl; + *snv = csl; + + } + + } + + return 0; + +/* End of DLAGS2 */ + +} /* dlags2_ */ + diff --git a/lapack-netlib/SRC/dlagtf.c b/lapack-netlib/SRC/dlagtf.c new file mode 100644 index 000000000..2580ea9d9 --- /dev/null +++ b/lapack-netlib/SRC/dlagtf.c @@ -0,0 +1,662 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAGTF 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 DLAGTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) */ + +/* INTEGER INFO, N */ +/* DOUBLE PRECISION LAMBDA, TOL */ +/* INTEGER IN( * ) */ +/* DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAGTF 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 DLAGTF may */ +/* > be used, in conjunction with DLAGTS, 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > On entry, the scalar lambda. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION 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 dlagtf_(integer *n, doublereal *a, doublereal *lambda, + doublereal *b, doublereal *c__, doublereal *tol, doublereal *d__, + integer *in, integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2; + + /* Local variables */ + doublereal temp, mult; + integer k; + doublereal scale1, scale2; + extern doublereal dlamch_(char *); + doublereal tl; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal 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_("DLAGTF", &i__1, (ftnlen)6); + return 0; + } + + if (*n == 0) { + return 0; + } + + a[1] -= *lambda; + in[*n] = 0; + if (*n == 1) { + if (a[1] == 0.) { + in[1] = 1; + } + return 0; + } + + eps = dlamch_("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 = (d__1 = c__[k], abs(d__1)) + (d__2 = a[k + 1], abs(d__2)); + if (k < *n - 1) { + scale2 += (d__1 = b[k + 1], abs(d__1)); + } + if (a[k] == 0.) { + piv1 = 0.; + } else { + piv1 = (d__1 = a[k], abs(d__1)) / scale1; + } + if (c__[k] == 0.) { + in[k] = 0; + piv2 = 0.; + scale1 = scale2; + if (k < *n - 1) { + d__[k] = 0.; + } + } else { + piv2 = (d__1 = c__[k], abs(d__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.; + } + } 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 ((d__1 = a[*n], abs(d__1)) <= scale1 * tl && in[*n] == 0) { + in[*n] = *n; + } + + return 0; + +/* End of DLAGTF */ + +} /* dlagtf_ */ + diff --git a/lapack-netlib/SRC/dlagtm.c b/lapack-netlib/SRC/dlagtm.c new file mode 100644 index 000000000..36b3eb552 --- /dev/null +++ b/lapack-netlib/SRC/dlagtm.c @@ -0,0 +1,705 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAGTM 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 DLAGTM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, */ +/* B, LDB ) */ + +/* CHARACTER TRANS */ +/* INTEGER LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION ALPHA, BETA */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAGTM 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 DOUBLE PRECISION */ +/* > The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */ +/* > it is assumed to be 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) sub-diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) super-diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlagtm_(char *trans, integer *n, integer *nrhs, + doublereal *alpha, doublereal *dl, doublereal *d__, doublereal *du, + doublereal *x, integer *ldx, doublereal *beta, doublereal *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.) { + 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.; +/* L10: */ + } +/* L20: */ + } + } else if (*beta == -1.) { + 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.) { + 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.) { + 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 DLAGTM */ + +} /* dlagtm_ */ + diff --git a/lapack-netlib/SRC/dlagts.c b/lapack-netlib/SRC/dlagts.c new file mode 100644 index 000000000..6822a88ab --- /dev/null +++ b/lapack-netlib/SRC/dlagts.c @@ -0,0 +1,787 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAGTS 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 DLAGTS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) */ + +/* INTEGER INFO, JOB, N */ +/* DOUBLE PRECISION TOL */ +/* INTEGER IN( * ) */ +/* DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAGTS 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 DLAGTF. 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 DLAGTS 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 DOUBLE PRECISION array, dimension (N) */ +/* > On entry, A must contain the diagonal elements of U as */ +/* > returned from DLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, B must contain the first super-diagonal elements of */ +/* > U as returned from DLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, C must contain the sub-diagonal elements of L as */ +/* > returned from DLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N-2) */ +/* > On entry, D must contain the second super-diagonal elements */ +/* > of U as returned from DLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IN */ +/* > \verbatim */ +/* > IN is INTEGER array, dimension (N) */ +/* > On entry, IN must contain details of the matrix P as returned */ +/* > from DLAGTF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 dlagts_(integer *job, integer *n, doublereal *a, + doublereal *b, doublereal *c__, doublereal *d__, integer *in, + doublereal *y, doublereal *tol, integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + doublereal temp, pert; + integer k; + doublereal absak, sfmin, ak; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal 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_("DLAGTS", &i__1, (ftnlen)6); + return 0; + } + + if (*n == 0) { + return 0; + } + + eps = dlamch_("Epsilon"); + sfmin = dlamch_("Safe minimum"); + bignum = 1. / sfmin; + + if (*job < 0) { + if (*tol <= 0.) { + *tol = abs(a[1]); + if (*n > 1) { +/* Computing MAX */ + d__1 = *tol, d__2 = abs(a[2]), d__1 = f2cmax(d__1,d__2), d__2 = + abs(b[1]); + *tol = f2cmax(d__1,d__2); + } + i__1 = *n; + for (k = 3; k <= i__1; ++k) { +/* Computing MAX */ + d__4 = *tol, d__5 = (d__1 = a[k], abs(d__1)), d__4 = f2cmax(d__4, + d__5), d__5 = (d__2 = b[k - 1], abs(d__2)), d__4 = + f2cmax(d__4,d__5), d__5 = (d__3 = d__[k - 2], abs(d__3)); + *tol = f2cmax(d__4,d__5); +/* L10: */ + } + *tol *= eps; + if (*tol == 0.) { + *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.) { + if (absak < sfmin) { + if (absak == 0. || 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 = d_sign(tol, &ak); +L40: + absak = abs(ak); + if (absak < 1.) { + if (absak < sfmin) { + if (absak == 0. || 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.) { + if (absak < sfmin) { + if (absak == 0. || 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 = d_sign(tol, &ak); +L70: + absak = abs(ak); + if (absak < 1.) { + if (absak < sfmin) { + if (absak == 0. || 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 DLAGTS */ + + return 0; +} /* dlagts_ */ + diff --git a/lapack-netlib/SRC/dlagv2.c b/lapack-netlib/SRC/dlagv2.c new file mode 100644 index 000000000..39a9fd2c6 --- /dev/null +++ b/lapack-netlib/SRC/dlagv2.c @@ -0,0 +1,797 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAGV2 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 DLAGV2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, */ +/* CSR, SNR ) */ + +/* INTEGER LDA, LDB */ +/* DOUBLE PRECISION CSL, CSR, SNL, SNR */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), */ +/* $ B( LDB, * ), BETA( 2 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAGV2 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > The cosine of the left rotation matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNL */ +/* > \verbatim */ +/* > SNL is DOUBLE PRECISION */ +/* > The sine of the left rotation matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSR */ +/* > \verbatim */ +/* > CSR is DOUBLE PRECISION */ +/* > The cosine of the right rotation matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNR */ +/* > \verbatim */ +/* > SNR is DOUBLE PRECISION */ +/* > 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 doubleOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int dlagv2_(doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *alphar, doublereal *alphai, doublereal * + beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal * + snr) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *), dlag2_( + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + doublereal r__, t, anorm, bnorm, h1, h2, h3, scale1, scale2; + extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + extern doublereal dlapy2_(doublereal *, doublereal *); + doublereal ascale, bscale; + extern doublereal dlamch_(char *); + doublereal wi, qq, rr, safmin; + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + doublereal 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 = dlamch_("S"); + ulp = dlamch_("P"); + +/* Scale A */ + +/* Computing MAX */ + d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs( + d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 = + a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = f2cmax(d__5,d__6); + anorm = f2cmax(d__5,safmin); + ascale = 1. / 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 */ + d__4 = (d__3 = b[b_dim1 + 1], abs(d__3)), d__5 = (d__1 = b[(b_dim1 << 1) + + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 2], abs(d__2)), d__4 + = f2cmax(d__4,d__5); + bnorm = f2cmax(d__4,safmin); + bscale = 1. / 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 ((d__1 = a[a_dim1 + 2], abs(d__1)) <= ulp) { + *csl = 1.; + *snl = 0.; + *csr = 1.; + *snr = 0.; + a[a_dim1 + 2] = 0.; + b[b_dim1 + 2] = 0.; + wi = 0.; + +/* Check if B is singular */ + + } else if ((d__1 = b[b_dim1 + 1], abs(d__1)) <= ulp) { + dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); + *csr = 1.; + *snr = 0.; + drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + a[a_dim1 + 2] = 0.; + b[b_dim1 + 1] = 0.; + b[b_dim1 + 2] = 0.; + wi = 0.; + + } else if ((d__1 = b[(b_dim1 << 1) + 2], abs(d__1)) <= ulp) { + dlartg_(&a[(a_dim1 << 1) + 2], &a[a_dim1 + 2], csr, snr, &t); + *snr = -(*snr); + drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, csr, + snr); + drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, csr, + snr); + *csl = 1.; + *snl = 0.; + a[a_dim1 + 2] = 0.; + b[b_dim1 + 2] = 0.; + b[(b_dim1 << 1) + 2] = 0.; + wi = 0.; + + } else { + +/* B is nonsingular, first compute the eigenvalues of (A,B) */ + + dlag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, & + scale2, &wr1, &wr2, &wi); + + if (wi == 0.) { + +/* 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 = dlapy2_(&h1, &h2); + d__1 = scale1 * a[a_dim1 + 2]; + qq = dlapy2_(&d__1, &h3); + + if (rr > qq) { + +/* find right rotation matrix to zero 1,1 element of */ +/* (sA - wB) */ + + dlartg_(&h2, &h1, csr, snr, &t); + + } else { + +/* find right rotation matrix to zero 2,1 element of */ +/* (sA - wB) */ + + d__1 = scale1 * a[a_dim1 + 2]; + dlartg_(&h3, &d__1, csr, snr, &t); + + } + + *snr = -(*snr); + drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, + csr, snr); + drot_(&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 */ + d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[(a_dim1 << 1) + + 1], abs(d__2)), d__6 = (d__3 = a[a_dim1 + 2], abs(d__3) + ) + (d__4 = a[(a_dim1 << 1) + 2], abs(d__4)); + h1 = f2cmax(d__5,d__6); +/* Computing MAX */ + d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], abs(d__3) + ) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); + h2 = f2cmax(d__5,d__6); + + if (scale1 * h1 >= abs(wr1) * h2) { + +/* find left rotation matrix Q to zero out B(2,1) */ + + dlartg_(&b[b_dim1 + 1], &b[b_dim1 + 2], csl, snl, &r__); + + } else { + +/* find left rotation matrix Q to zero out A(2,1) */ + + dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); + + } + + drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + + a[a_dim1 + 2] = 0.; + b[b_dim1 + 2] = 0.; + + } else { + +/* a pair of complex conjugate eigenvalues */ +/* first compute the SVD of the matrix B */ + + dlasv2_(&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 DLASV2 */ + + drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, + csr, snr); + drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, + csr, snr); + + b[b_dim1 + 2] = 0.; + b[(b_dim1 << 1) + 1] = 0.; + + } + + } + +/* 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.) { + alphar[1] = a[a_dim1 + 1]; + alphar[2] = a[(a_dim1 << 1) + 2]; + alphai[1] = 0.; + alphai[2] = 0.; + 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.; + beta[2] = 1.; + } + + return 0; + +/* End of DLAGV2 */ + +} /* dlagv2_ */ + diff --git a/lapack-netlib/SRC/dlahqr.c b/lapack-netlib/SRC/dlahqr.c new file mode 100644 index 000000000..00a581f9d --- /dev/null +++ b/lapack-netlib/SRC/dlahqr.c @@ -0,0 +1,1090 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAHQR 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 DLAHQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAHQR( 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 */ +/* DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAHQR is an auxiliary routine called by DHSEQR to update the */ +/* > eigenvalues and Schur decomposition already computed by DHSEQR, 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). DLAHQR 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is DOUBLE PRECISION array, dimension (N) */ +/* > The real and imaginary parts, respectively, of the 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 DOUBLE PRECISION array, dimension (LDZ,N) */ +/* > If WANTZ is .TRUE., on entry Z must contain the current */ +/* > matrix Z of transformations accumulated by DHSEQR, 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, DLAHQR 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 doubleOTHERauxiliary */ + +/* > \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 DLAHQR 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 dlahqr_(logical *wantt, logical *wantz, integer *n, + integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal + *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *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; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer i__, j, k, l, m; + doublereal s, v[3]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer itmax, i1, i2; + doublereal t1, t2, t3, v2, v3; + extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + doublereal aa, ab, ba, bb; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + doublereal h11, h12, h21, h22, cs; + integer nh; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *); + doublereal sn; + integer nr; + doublereal tr; + integer nz; + doublereal safmin, safmax, rtdisc, smlnum, det, h21s; + integer its; + doublereal 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.; + return 0; + } + +/* ==== clear out the trash ==== */ + i__1 = *ihi - 3; + for (j = *ilo; j <= i__1; ++j) { + h__[j + 2 + j * h_dim1] = 0.; + h__[j + 3 + j * h_dim1] = 0.; +/* L10: */ + } + if (*ilo <= *ihi - 2) { + h__[*ihi + (*ihi - 2) * h_dim1] = 0.; + } + + nh = *ihi - *ilo + 1; + nz = *ihiz - *iloz + 1; + +/* Set machine-dependent constants for the stopping criterion. */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) 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 ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) { + goto L40; + } + tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 = + h__[k + k * h_dim1], abs(d__2)); + if (tst == 0.) { + if (k - 2 >= *ilo) { + tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1)); + } + if (k + 1 <= *ihi) { + tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__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 ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) { +/* Computing MAX */ + d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( + d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); + ab = f2cmax(d__3,d__4); +/* Computing MIN */ + d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( + d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); + ba = f2cmin(d__3,d__4); +/* Computing MAX */ + d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(d__2)); + aa = f2cmax(d__3,d__4); +/* Computing MIN */ + d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(d__2)); + bb = f2cmin(d__3,d__4); + s = aa + ab; +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * (bb * (aa / s)); + if (ba * (ab / s) <= f2cmax(d__1,d__2)) { + goto L40; + } + } +/* L30: */ + } +L40: + l = k; + if (l > *ilo) { + +/* H(L,L-1) is negligible */ + + h__[l + (l - 1) * h_dim1] = 0.; + } + +/* 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 = (d__1 = h__[l + 1 + l * h_dim1], abs(d__1)) + (d__2 = h__[l + + 2 + (l + 1) * h_dim1], abs(d__2)); + h11 = s * .75 + h__[l + l * h_dim1]; + h12 = s * -.4375; + h21 = s; + h22 = h11; + } else if (its == 20) { + +/* Exceptional shift. */ + + s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 = + h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2)); + h11 = s * .75 + h__[i__ + i__ * h_dim1]; + h12 = s * -.4375; + 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.) { + rt1r = 0.; + rt1i = 0.; + rt2r = 0.; + rt2i = 0.; + } else { + h11 /= s; + h21 /= s; + h12 /= s; + h22 /= s; + tr = (h11 + h22) / 2.; + det = (h11 - tr) * (h22 - tr) - h12 * h21; + rtdisc = sqrt((abs(det))); + if (det >= 0.) { + +/* ==== 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 ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs( + d__2))) { + rt1r *= s; + rt2r = rt1r; + } else { + rt2r *= s; + rt1r = rt2r; + } + rt1i = 0.; + rt2i = 0.; + } + } + +/* 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 = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__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 ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) + + abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m - + 1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1], + abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs( + d__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) { + dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); + } + dlarfg_(&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.; + if (k < i__ - 1) { + h__[k + 2 + (k - 1) * h_dim1] = 0.; + } + } 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. - 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.; + } 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. */ + + dlanv2_(&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__; + drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[ + i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn); + } + i__1 = i__ - i1 - 1; + drot_(&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. */ + + drot_(&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 DLAHQR */ + +} /* dlahqr_ */ + diff --git a/lapack-netlib/SRC/dlahr2.c b/lapack-netlib/SRC/dlahr2.c new file mode 100644 index 000000000..b9006c3d2 --- /dev/null +++ b/lapack-netlib/SRC/dlahr2.c @@ -0,0 +1,766 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAHR2 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 DLAHR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */ + +/* INTEGER K, LDA, LDT, LDY, N, NB */ +/* DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), */ +/* $ Y( LDY, NB ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAHR2 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 DGEHRD. */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* > \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 dlahr2_(integer *n, integer *k, integer *nb, doublereal * + a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, + doublereal *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; + doublereal d__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemm_(char *, char *, integer *, integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dgemv_( + char *, integer *, integer *, doublereal *, doublereal *, integer + *, doublereal *, integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *, + integer *), dtrmm_(char *, char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *), daxpy_(integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *), + dtrmv_(char *, char *, char *, integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal ei; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *), dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, 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; + dgemv_("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; + dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + dtrmv_("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; + dgemv_("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; + dtrmv_("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; + dgemv_("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; + dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1] + , lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + daxpy_(&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; + dlarfg_(&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.; + +/* Compute Y(K+1:N,I) */ + + i__2 = *n - *k; + i__3 = *n - *k - i__ + 1; + dgemv_("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; + dgemv_("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; + dgemv_("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; + dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1); + +/* Compute T(1:I,I) */ + + i__2 = i__ - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + dtrmv_("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) */ + + dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy); + dtrmm_("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; + dgemm_("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); + } + dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[ + t_offset], ldt, &y[y_offset], ldy); + + return 0; + +/* End of DLAHR2 */ + +} /* dlahr2_ */ + diff --git a/lapack-netlib/SRC/dlaic1.c b/lapack-netlib/SRC/dlaic1.c new file mode 100644 index 000000000..0e5e0a9a5 --- /dev/null +++ b/lapack-netlib/SRC/dlaic1.c @@ -0,0 +1,757 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAIC1 applies one step of incremental condition estimation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLAIC1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) */ + +/* INTEGER J, JOB */ +/* DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR */ +/* DOUBLE PRECISION W( J ), X( J ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAIC1 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 DLAIC1 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 DOUBLE PRECISION array, dimension (J) */ +/* > The j-vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SEST */ +/* > \verbatim */ +/* > SEST is DOUBLE PRECISION */ +/* > Estimated singular value of j by j matrix L */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (J) */ +/* > The j-vector w. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GAMMA */ +/* > \verbatim */ +/* > GAMMA is DOUBLE PRECISION */ +/* > The diagonal element gamma. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SESTPR */ +/* > \verbatim */ +/* > SESTPR is DOUBLE PRECISION */ +/* > Estimated singular value of (j+1) by (j+1) matrix Lhat. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION */ +/* > Sine needed in forming xhat. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION */ +/* > 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlaic1_(integer *job, integer *j, doublereal *x, + doublereal *sest, doublereal *w, doublereal *gamma, doublereal * + sestpr, doublereal *s, doublereal *c__) +{ + /* System generated locals */ + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal sine, test, zeta1, zeta2, b, t, alpha, norma, s1, s2; + extern doublereal dlamch_(char *); + doublereal absgam, absalp, 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 = dlamch_("Epsilon"); + alpha = ddot_(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.) { + s1 = f2cmax(absgam,absalp); + if (s1 == 0.) { + *s = 0.; + *c__ = 1.; + *sestpr = 0.; + } 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.; + *c__ = 0.; + 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.; + *c__ = 0.; + *sestpr = s2; + } else { + *s = 0.; + *c__ = 1.; + *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.); + *sestpr = s2 * *s; + *c__ = *gamma / s2 / *s; + *s = d_sign(&c_b5, &alpha) / *s; + } else { + tmp = s2 / s1; + *c__ = sqrt(tmp * tmp + 1.); + *sestpr = s1 * *c__; + *s = alpha / s1 / *c__; + *c__ = d_sign(&c_b5, gamma) / *c__; + } + return 0; + } else { + +/* normal case */ + + zeta1 = alpha / absest; + zeta2 = *gamma / absest; + + b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5; + *c__ = zeta1 * zeta1; + if (b > 0.) { + t = *c__ / (b + sqrt(b * b + *c__)); + } else { + t = sqrt(b * b + *c__) - b; + } + + sine = -zeta1 / t; + cosine = -zeta2 / (t + 1.); + tmp = sqrt(sine * sine + cosine * cosine); + *s = sine / tmp; + *c__ = cosine / tmp; + *sestpr = sqrt(t + 1.) * absest; + return 0; + } + + } else if (*job == 2) { + +/* Estimating smallest singular value */ + +/* special cases */ + + if (*sest == 0.) { + *sestpr = 0.; + if (f2cmax(absgam,absalp) == 0.) { + sine = 1.; + cosine = 0.; + } else { + sine = -(*gamma); + cosine = alpha; + } +/* Computing MAX */ + d__1 = abs(sine), d__2 = abs(cosine); + s1 = f2cmax(d__1,d__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.; + *c__ = 1.; + *sestpr = absgam; + return 0; + } else if (absalp <= eps * absest) { + s1 = absgam; + s2 = absest; + if (s1 <= s2) { + *s = 0.; + *c__ = 1.; + *sestpr = s1; + } else { + *s = 1.; + *c__ = 0.; + *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.); + *sestpr = absest * (tmp / *c__); + *s = -(*gamma / s2) / *c__; + *c__ = d_sign(&c_b5, &alpha) / *c__; + } else { + tmp = s2 / s1; + *s = sqrt(tmp * tmp + 1.); + *sestpr = absest / *s; + *c__ = alpha / s1 / *s; + *s = -d_sign(&c_b5, gamma) / *s; + } + return 0; + } else { + +/* normal case */ + + zeta1 = alpha / absest; + zeta2 = *gamma / absest; + +/* Computing MAX */ + d__3 = zeta1 * zeta1 + 1. + (d__1 = zeta1 * zeta2, abs(d__1)), + d__4 = (d__2 = zeta1 * zeta2, abs(d__2)) + zeta2 * zeta2; + norma = f2cmax(d__3,d__4); + +/* See if root is closer to zero or to ONE */ + + test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.; + if (test >= 0.) { + +/* root is close to zero, compute directly */ + + b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5; + *c__ = zeta2 * zeta2; + t = *c__ / (b + sqrt((d__1 = b * b - *c__, abs(d__1)))); + sine = zeta1 / (1. - t); + cosine = -zeta2 / t; + *sestpr = sqrt(t + eps * 4. * eps * norma) * absest; + } else { + +/* root is closer to ONE, shift by that amount */ + + b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5; + *c__ = zeta1 * zeta1; + if (b >= 0.) { + t = -(*c__) / (b + sqrt(b * b + *c__)); + } else { + t = b - sqrt(b * b + *c__); + } + sine = -zeta1 / t; + cosine = -zeta2 / (t + 1.); + *sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest; + } + tmp = sqrt(sine * sine + cosine * cosine); + *s = sine / tmp; + *c__ = cosine / tmp; + return 0; + + } + } + return 0; + +/* End of DLAIC1 */ + +} /* dlaic1_ */ + diff --git a/lapack-netlib/SRC/dlaisnan.c b/lapack-netlib/SRC/dlaisnan.c new file mode 100644 index 000000000..7d7fbc40e --- /dev/null +++ b/lapack-netlib/SRC/dlaisnan.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 DLAISNAN 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 DLAISNAN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) */ + +/* DOUBLE PRECISION DIN1, DIN2 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is not for general use. It exists solely to avoid */ +/* > over-optimization in DISNAN. */ +/* > */ +/* > DLAISNAN 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] DIN1 */ +/* > \verbatim */ +/* > DIN1 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIN2 */ +/* > \verbatim */ +/* > DIN2 is DOUBLE PRECISION */ +/* > 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 dlaisnan_(doublereal *din1, doublereal *din2) +{ + /* 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 = *din1 != *din2; + return ret_val; +} /* dlaisnan_ */ + diff --git a/lapack-netlib/SRC/dlaln2.c b/lapack-netlib/SRC/dlaln2.c new file mode 100644 index 000000000..adbd62ee4 --- /dev/null +++ b/lapack-netlib/SRC/dlaln2.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 DLALN2 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 DLALN2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLALN2( 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 */ +/* DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALN2 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 DLALN2, 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > The coefficient c, which A is multiplied by. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > The 1,1 element in the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D2 */ +/* > \verbatim */ +/* > D2 is DOUBLE PRECISION */ +/* > The 2,2 element in the diagonal matrix D. Not used if NA=1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > The real part of the scalar "w". */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WI */ +/* > \verbatim */ +/* > WI is DOUBLE PRECISION */ +/* > The imaginary part of the scalar "w". Not used if NW=1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NW) */ +/* > The NA x NW matrix X (unknowns), as computed by DLALN2. */ +/* > 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int dlaln2_(logical *ltrans, integer *na, integer *nw, + doublereal *smin, doublereal *ca, doublereal *a, integer *lda, + doublereal *d1, doublereal *d2, doublereal *b, integer *ldb, + doublereal *wr, doublereal *wi, doublereal *x, integer *ldx, + doublereal *scale, doublereal *xnorm, integer *info) +{ + /* Initialized data */ + + static logical zswap[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; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + static doublereal equiv_0[4], equiv_1[4]; + + /* Local variables */ + doublereal bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s; + integer j; + doublereal u22abs; + integer icmax; + doublereal bnorm, cnorm, smini; +#define ci (equiv_0) +#define cr (equiv_1) + extern doublereal dlamch_(char *); + extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + doublereal bignum, bi1, bi2, br1, br2, smlnum, xi1, xi2, xr1, xr2, ci21, + ci22, cr21, cr22, li21, csi, ui11, lr21, ui12, ui22; +#define civ (equiv_0) + doublereal 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. * dlamch_("Safe minimum"); + bignum = 1. / smlnum; + smini = f2cmax(*smin,smlnum); + +/* Don't check for input errors */ + + *info = 0; + +/* Standard Initializations */ + + *scale = 1.; + + 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 = (d__1 = b[b_dim1 + 1], abs(d__1)); + if (cnorm < 1. && bnorm > 1.) { + if (bnorm > bignum * cnorm) { + *scale = 1. / bnorm; + } + } + +/* Compute X */ + + x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr; + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__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.; + cnorm = smini; + *info = 1; + } + +/* Check scaling for X = B / C */ + + bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << + 1) + 1], abs(d__2)); + if (cnorm < 1. && bnorm > 1.) { + if (bnorm > bignum * cnorm) { + *scale = 1. / bnorm; + } + } + +/* Compute X */ + + d__1 = *scale * b[b_dim1 + 1]; + d__2 = *scale * b[(b_dim1 << 1) + 1]; + dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1) + + 1]); + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << + 1) + 1], abs(d__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.; + icmax = 0; + + for (j = 1; j <= 4; ++j) { + if ((d__1 = crv[j - 1], abs(d__1)) > cmax) { + cmax = (d__1 = crv[j - 1], abs(d__1)); + icmax = j; + } +/* L10: */ + } + +/* If norm(C) < SMINI, use SMINI*identity. */ + + if (cmax < smini) { +/* Computing MAX */ + d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[ + b_dim1 + 2], abs(d__2)); + bnorm = f2cmax(d__3,d__4); + if (smini < 1. && bnorm > 1.) { + if (bnorm > bignum * smini) { + *scale = 1. / 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. / 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 */ + d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2); + bbnd = f2cmax(d__2,d__3); + if (bbnd > 1. && abs(ur22) < 1.) { + if (bbnd >= bignum * abs(ur22)) { + *scale = 1. / bbnd; + } + } + + xr2 = br2 * *scale / ur22; + xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12); + if (zswap[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 */ + d__1 = abs(xr1), d__2 = abs(xr2); + *xnorm = f2cmax(d__1,d__2); + +/* Further scaling if norm(A) norm(X) > overflow */ + + if (*xnorm > 1. && cmax > 1.) { + 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.; + ci[2] = 0.; + ci[3] = -(*wi) * *d2; + cmax = 0.; + icmax = 0; + + for (j = 1; j <= 4; ++j) { + if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs( + d__2)) > cmax) { + cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1] + , abs(d__2)); + icmax = j; + } +/* L20: */ + } + +/* If norm(C) < SMINI, use SMINI*identity. */ + + if (cmax < smini) { +/* Computing MAX */ + d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 + << 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], + abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); + bnorm = f2cmax(d__5,d__6); + if (smini < 1. && bnorm > 1.) { + if (bnorm > bignum * smini) { + *scale = 1. / 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 */ + d__1 = temp; + ur11r = 1. / (ur11 * (d__1 * d__1 + 1.)); + ui11r = -temp * ur11r; + } else { + temp = ur11 / ui11; +/* Computing 2nd power */ + d__1 = temp; + ui11r = -1. / (ui11 * (d__1 * d__1 + 1.)); + 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. / ur11; + ui11r = 0.; + 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.; + *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 */ + d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r)) + ), d__2 = abs(br2) + abs(bi2); + bbnd = f2cmax(d__1,d__2); + if (bbnd > 1. && u22abs < 1.) { + if (bbnd >= bignum * u22abs) { + *scale = 1. / bbnd; + br1 = *scale * br1; + bi1 = *scale * bi1; + br2 = *scale * br2; + bi2 = *scale * bi2; + } + } + + dladiv_(&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 (zswap[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 */ + d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2); + *xnorm = f2cmax(d__1,d__2); + +/* Further scaling if norm(A) norm(X) > overflow */ + + if (*xnorm > 1. && cmax > 1.) { + 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 DLALN2 */ + +} /* dlaln2_ */ + +#undef crv +#undef civ +#undef cr +#undef ci + + diff --git a/lapack-netlib/SRC/dlals0.c b/lapack-netlib/SRC/dlals0.c new file mode 100644 index 000000000..4f30420da --- /dev/null +++ b/lapack-netlib/SRC/dlals0.c @@ -0,0 +1,955 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLALS0 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 DLALS0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLALS0( 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 */ +/* DOUBLE PRECISION C, S */ +/* INTEGER GIVCOL( LDGCOL, * ), PERM( * ) */ +/* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), */ +/* $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), */ +/* $ POLES( LDGNUM, * ), WORK( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALS0 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION 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 doubleOTHERcomputational */ + +/* > \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 dlals0_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal + *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, + integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal * + poles, doublereal *difl, doublereal *difr, doublereal *z__, integer * + k, doublereal *c__, doublereal *s, doublereal *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; + doublereal d__1; + + /* Local variables */ + doublereal temp; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__, j, m, n; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal diflj, difrj, dsigj; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *); + extern doublereal dlamc3_(doublereal *, doublereal *); + doublereal dj; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dlacpy_(char *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + doublereal dsigjp; + 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_("DLALS0", &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__) { + drot_(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. */ + + dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(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) { + dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); + if (z__[1] < 0.) { + dscal_(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. || poles[j + (poles_dim1 << 1)] == 0.) { + work[j] = 0.; + } 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. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&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. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigjp) + difrj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } +/* L40: */ + } + work[1] = -1.; + temp = dnrm2_(k, &work[1], &c__1); + dgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & + c__1, &c_b13, &b[j + b_dim1], ldb); + dlascl_("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; + dlacpy_("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) { + dcopy_(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.) { + work[j] = 0.; + } 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.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__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.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[ + i__]) / (dsigj + poles[i__ + poles_dim1]) / + difr[i__ + (difr_dim1 << 1)]; + } +/* L70: */ + } + dgemv_("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) { + dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); + drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, + s); + } + if (*k < f2cmax(m,n)) { + i__1 = n - *k; + dlacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + + bx_dim1], ldbx); + } + +/* Step (3R): permute rows of B. */ + + dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); + if (*sqre == 1) { + dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); + } + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(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__) { + d__1 = -givnum[i__ + givnum_dim1]; + drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &d__1); +/* L100: */ + } + } + + return 0; + +/* End of DLALS0 */ + +} /* dlals0_ */ + diff --git a/lapack-netlib/SRC/dlalsa.c b/lapack-netlib/SRC/dlalsa.c new file mode 100644 index 000000000..32a29e928 --- /dev/null +++ b/lapack-netlib/SRC/dlalsa.c @@ -0,0 +1,951 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLALSA 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 DLALSA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLALSA( 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, * ) */ +/* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), */ +/* $ DIFL( LDU, * ), DIFR( LDU, * ), */ +/* $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), */ +/* $ U( LDU, * ), VT( LDU, * ), WORK( * ), */ +/* $ Z( LDU, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALSA 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, DLALSA applies the inverse of the left singular vector */ +/* > matrix of an upper bidiagonal matrix to the right hand side; and if */ +/* > ICOMPQ = 1, DLALSA applies the right singular vector matrix to the */ +/* > right hand side. The singular vector matrices were generated in */ +/* > compact form by DLALSA. */ +/* > \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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension ( LDU, NLVL ). */ +/* > where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFR */ +/* > \verbatim */ +/* > DIFR is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERcomputational */ + +/* > \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 dlalsa_(integer *icompq, integer *smlsiz, integer *n, + integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer * + ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, + doublereal *difl, doublereal *difr, doublereal *z__, doublereal * + poles, integer *givptr, integer *givcol, integer *ldgcol, integer * + perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal * + 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; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + integer inode, ndiml, ndimr; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer i1; + extern /* Subroutine */ int dlals0_(integer *, integer *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *); + integer ic, lf, nd, ll, nl, nr; + extern /* Subroutine */ int dlasdt_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + 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_("DLALSA", &i__1, (ftnlen)6); + return 0; + } + +/* Book-keeping and setting up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + + dlasdt_(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 DLASDQ. 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; + dgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf + + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); + dgemm_("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]; + dcopy_(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; + dlals0_(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; + dlals0_(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 DLASDQ. 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; + dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & + b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); + dgemm_("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 DLALSA */ + +} /* dlalsa_ */ + diff --git a/lapack-netlib/SRC/dlalsd.c b/lapack-netlib/SRC/dlalsd.c new file mode 100644 index 000000000..b8d7d1df3 --- /dev/null +++ b/lapack-netlib/SRC/dlalsd.c @@ -0,0 +1,978 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLALSD 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 DLALSD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, */ +/* RANK, WORK, IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALSD 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION */ +/* > 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 DOUBLE PRECISION 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 doubleOTHERcomputational */ + +/* > \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 dlalsd_(char *uplo, integer *smlsiz, integer *n, integer + *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, + doublereal *rcond, integer *rank, doublereal *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer difl, difr; + doublereal rcnd; + integer perm, nsub; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer nlvl, sqre, bxst, c__, i__, j, k; + doublereal r__; + integer s, u; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + integer z__; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer poles, sizei, nsize, nwork, icmpq1, icmpq2; + doublereal cs; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int dlasda_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *); + integer bx; + extern /* Subroutine */ int dlalsa_(integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *); + doublereal sn; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + integer st; + extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer + *, integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *); + integer vt; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), dlaset_(char *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *), xerbla_(char *, + integer *, ftnlen); + integer givcol; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, + integer *); + doublereal orgnrm; + integer givnum, givptr, nm1, smlszp, st1; + doublereal eps; + integer iwk; + doublereal 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_("DLALSD", &i__1, (ftnlen)6); + return 0; + } + + eps = dlamch_("Epsilon"); + +/* Set up the tolerance. */ + + if (*rcond <= 0. || *rcond >= 1.) { + rcnd = eps; + } else { + rcnd = *rcond; + } + + *rank = 0; + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } else if (*n == 1) { + if (d__[1] == 0.) { + dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); + } else { + *rank = 1; + dlascl_("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__) { + dlartg_(&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) { + drot_(&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]; + drot_(&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 = dlanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.) { + dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); + return 0; + } + + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info); + dlascl_("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; + dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n); + dlasdq_("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 * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= tol) { + dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb); + } else { + dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ + i__ + b_dim1], ldb, info); + ++(*rank); + } +/* L40: */ + } + dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & + c_b6, &work[nwork], n); + dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb); + +/* Unscale. */ + + dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, + info); + dlasrt_("D", n, &d__[1], info); + dlascl_("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((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / + log(2.)) + 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 ((d__1 = d__[i__], abs(d__1)) < eps) { + d__[i__] = d_sign(&eps, &d__[i__]); + } +/* L50: */ + } + + i__1 = nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = e[i__], abs(d__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 ((d__1 = e[i__], abs(d__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; + dcopy_(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. */ + + dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); + } else if (nsize <= *smlsiz) { + +/* This is a small subproblem and is solved by DLASDQ. */ + + dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], + n); + dlasdq_("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; + } + dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + + st1], n); + } else { + +/* A large problem. Solve it using divide and conquer. */ + + dlasda_(&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; + dlalsa_(&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 * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__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 ((d__1 = d__[i__], abs(d__1)) <= tol) { + dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n); + } else { + ++(*rank); + dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ + bx + i__ - 1], n, info); + } + d__[i__] = (d__1 = d__[i__], abs(d__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) { + dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); + } else if (nsize <= *smlsiz) { + dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, + &work[bxst], n, &c_b6, &b[st + b_dim1], ldb); + } else { + dlalsa_(&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. */ + + dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info); + dlasrt_("D", n, &d__[1], info); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, + info); + + return 0; + +/* End of DLALSD */ + +} /* dlalsd_ */ + diff --git a/lapack-netlib/SRC/dlamrg.c b/lapack-netlib/SRC/dlamrg.c new file mode 100644 index 000000000..58ce575ee --- /dev/null +++ b/lapack-netlib/SRC/dlamrg.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 DLAMRG 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 DLAMRG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) */ + +/* INTEGER DTRD1, DTRD2, N1, N2 */ +/* INTEGER INDEX( * ) */ +/* DOUBLE PRECISION A( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAMRG 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 DOUBLE PRECISION 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] DTRD1 */ +/* > \verbatim */ +/* > DTRD1 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DTRD2 */ +/* > \verbatim */ +/* > DTRD2 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 (DTRDx = 1) or descending */ +/* > (DTRDx = -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 dlamrg_(integer *n1, integer *n2, doublereal *a, integer + *dtrd1, integer *dtrd2, 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 (*dtrd1 > 0) { + ind1 = 1; + } else { + ind1 = *n1; + } + if (*dtrd2 > 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 += *dtrd1; + --n1sv; + } else { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; + --n2sv; + } + goto L10; + } +/* end while */ + if (n1sv == 0) { + i__1 = n2sv; + for (n1sv = 1; n1sv <= i__1; ++n1sv) { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; +/* L20: */ + } + } else { +/* N2SV .EQ. 0 */ + i__1 = n1sv; + for (n2sv = 1; n2sv <= i__1; ++n2sv) { + index[i__] = ind1; + ++i__; + ind1 += *dtrd1; +/* L30: */ + } + } + + return 0; + +/* End of DLAMRG */ + +} /* dlamrg_ */ + diff --git a/lapack-netlib/SRC/dlamswlq.c b/lapack-netlib/SRC/dlamswlq.c new file mode 100644 index 000000000..aa1b4916a --- /dev/null +++ b/lapack-netlib/SRC/dlamswlq.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 DLAMSWLQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAMSWLQ( 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 */ +/* > */ +/* > DLAMQRTS 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 (DLASWLQ) */ +/* > \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 DOUBLE PRECISION 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 */ +/* > DLASWLQ 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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) DOUBLE PRECISION 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 dlamswlq_(char *side, char *trans, integer *m, integer * + n, integer *k, integer *mb, integer *nb, doublereal *a, integer *lda, + doublereal *t, integer *ldt, doublereal *c__, integer *ldc, + doublereal *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 dgemlqt_(char *, char *, integer *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *), dtpmlqt_(char *, char *, integer *, integer *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, 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_("DLAMSWLQ", &i__1, (ftnlen)8); + work[1] = (doublereal) lw; + return 0; + } else if (lquery) { + work[1] = (doublereal) 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)) { + dgemlqt_(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; + dtpmlqt_("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; + dtpmlqt_("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) */ + + dgemlqt_("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; + dgemlqt_("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; + dtpmlqt_("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 */ + + dtpmlqt_("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; + dtpmlqt_("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; + dtpmlqt_("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) */ + + dgemlqt_("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); + ctr = 1; + ii = *n - kk + 1; + dgemlqt_("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; + dtpmlqt_("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 */ + + dtpmlqt_("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] = (doublereal) lw; + return 0; + +/* End of DLAMSWLQ */ + +} /* dlamswlq_ */ + diff --git a/lapack-netlib/SRC/dlamtsqr.c b/lapack-netlib/SRC/dlamtsqr.c new file mode 100644 index 000000000..83c124901 --- /dev/null +++ b/lapack-netlib/SRC/dlamtsqr.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 DLAMTSQR */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAMTSQR( 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 */ +/* > */ +/* > DLAMTSQR 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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) DOUBLE PRECISION 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 dlamtsqr_(char *side, char *trans, integer *m, integer * + n, integer *k, integer *mb, integer *nb, doublereal *a, integer *lda, + doublereal *t, integer *ldt, doublereal *c__, integer *ldc, + doublereal *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 dgemqrt_(char *, char *, integer *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *), dtpmqrt_(char *, char *, integer *, integer *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, 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] = (doublereal) lw; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAMTSQR", &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)) { + dgemqrt_(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; + dtpmqrt_("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; + dtpmqrt_("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) */ + + dgemqrt_("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; + dgemqrt_("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; + dtpmqrt_("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 */ + + dtpmqrt_("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; + dtpmqrt_("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; + dtpmqrt_("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) */ + + dgemqrt_("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; + dgemqrt_("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; + dtpmqrt_("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 */ + + dtpmqrt_("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] = (doublereal) lw; + return 0; + +/* End of DLAMTSQR */ + +} /* dlamtsqr_ */ + diff --git a/lapack-netlib/SRC/dlaneg.c b/lapack-netlib/SRC/dlaneg.c new file mode 100644 index 000000000..fdf555ad2 --- /dev/null +++ b/lapack-netlib/SRC/dlaneg.c @@ -0,0 +1,642 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLANEG computes the Sturm count. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLANEG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) */ + +/* INTEGER N, R */ +/* DOUBLE PRECISION PIVMIN, SIGMA */ +/* DOUBLE PRECISION D( * ), LLD( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANEG 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 DLARRB. */ +/* > */ +/* > 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 DOUBLE PRECISION array, dimension (N) */ +/* > The N diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LLD */ +/* > \verbatim */ +/* > LLD is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (N-1) elements L(i)*L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIGMA */ +/* > \verbatim */ +/* > SIGMA is DOUBLE PRECISION */ +/* > Shift amount in T - sigma I = L D L^T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is DOUBLE PRECISION */ +/* > 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 dlaneg_(integer *n, doublereal *d__, doublereal *lld, doublereal * + sigma, doublereal *pivmin, integer *r__) +{ + /* System generated locals */ + integer ret_val, i__1, i__2, i__3, i__4; + + /* Local variables */ + doublereal bsav; + integer j; + doublereal p, gamma, t, dplus; + integer bj; + extern logical disnan_(doublereal *); + integer negcnt; + logical sawnan; + doublereal 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.) { + ++neg1; + } + tmp = t / dplus; + t = tmp * lld[j] - *sigma; +/* L21: */ + } + sawnan = disnan_(&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.) { + ++neg1; + } + tmp = t / dplus; + if (disnan_(&tmp)) { + tmp = 1.; + } + 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.) { + ++neg2; + } + tmp = p / dminus; + p = tmp * d__[j] - *sigma; +/* L23: */ + } + sawnan = disnan_(&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.) { + ++neg2; + } + tmp = p / dminus; + if (disnan_(&tmp)) { + tmp = 1.; + } + 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.) { + ++negcnt; + } + ret_val = negcnt; + return ret_val; +} /* dlaneg_ */ + diff --git a/lapack-netlib/SRC/dlangb.c b/lapack-netlib/SRC/dlangb.c new file mode 100644 index 000000000..3aa4de824 --- /dev/null +++ b/lapack-netlib/SRC/dlangb.c @@ -0,0 +1,662 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLANGB 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 DLANGB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, */ +/* WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER KL, KU, LDAB, N */ +/* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANGB 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 DLANGB */ +/* > \verbatim */ +/* > */ +/* > DLANGB = ( 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 DLANGB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, DLANGB 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleGBauxiliary */ + +/* ===================================================================== */ +doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku, + doublereal *ab, integer *ldab, doublereal *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal temp; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, k, l; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal colssq[2], 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.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + 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 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; +/* 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 += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); +/* L30: */ + } + if (value < sum || disnan_(&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.; +/* 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__] += (d__1 = ab[k + i__ + j * ab_dim1], abs(d__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&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.; + ssq[1] = 1.; + 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.; + colssq[1] = 1.; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kl; + i__4 = f2cmin(i__2,i__3) - l + 1; + dlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of DLANGB */ + +} /* dlangb_ */ + diff --git a/lapack-netlib/SRC/dlange.c b/lapack-netlib/SRC/dlange.c new file mode 100644 index 000000000..dbcde1264 --- /dev/null +++ b/lapack-netlib/SRC/dlange.c @@ -0,0 +1,633 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLANGE 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 DLANGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER LDA, M, N */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANGE 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 DLANGE */ +/* > \verbatim */ +/* > */ +/* > DLANGE = ( 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 DLANGE as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. When M = 0, */ +/* > DLANGE 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, */ +/* > DLANGE is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(M,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION 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 doubleGEauxiliary */ + +/* ===================================================================== */ +doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer + *lda, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal temp; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal colssq[2], 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.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L30: */ + } + if (value < sum || disnan_(&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.; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&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.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + dlassq_(m, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of DLANGE */ + +} /* dlange_ */ + diff --git a/lapack-netlib/SRC/dlangt.c b/lapack-netlib/SRC/dlangt.c new file mode 100644 index 000000000..c2c27dd99 --- /dev/null +++ b/lapack-netlib/SRC/dlangt.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 DLANGT 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 DLANGT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) */ + +/* CHARACTER NORM */ +/* INTEGER N */ +/* DOUBLE PRECISION D( * ), DL( * ), DU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANGT 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 DLANGT */ +/* > \verbatim */ +/* > */ +/* > DLANGT = ( 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 DLANGT as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, DLANGT is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) sub-diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +doublereal dlangt_(char *norm, integer *n, doublereal *dl, doublereal *d__, + doublereal *du) +{ + /* System generated locals */ + integer i__1; + doublereal ret_val, d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal temp; + integer i__; + doublereal scale; + extern logical lsame_(char *, char *); + doublereal anorm; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal 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.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + anorm = (d__1 = d__[*n], abs(d__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__3 = (d__2 = dl[i__], abs(d__2)); + if (anorm < (d__1 = dl[i__], abs(d__1)) || disnan_(&d__3)) { + anorm = (d__4 = dl[i__], abs(d__4)); + } + d__3 = (d__2 = d__[i__], abs(d__2)); + if (anorm < (d__1 = d__[i__], abs(d__1)) || disnan_(&d__3)) { + anorm = (d__4 = d__[i__], abs(d__4)); + } + d__3 = (d__2 = du[i__], abs(d__2)); + if (anorm < (d__1 = du[i__], abs(d__1)) || disnan_(&d__3)) { + anorm = (d__4 = du[i__], abs(d__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 = (d__1 = d__[*n], abs(d__1)) + (d__2 = du[*n - 1], abs(d__2) + ); + if (anorm < temp || disnan_(&temp)) { + anorm = temp; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + temp = (d__1 = d__[i__], abs(d__1)) + (d__2 = dl[i__], abs( + d__2)) + (d__3 = du[i__ - 1], abs(d__3)); + if (anorm < temp || disnan_(&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 = (d__1 = d__[*n], abs(d__1)) + (d__2 = dl[*n - 1], abs(d__2) + ); + if (anorm < temp || disnan_(&temp)) { + anorm = temp; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + temp = (d__1 = d__[i__], abs(d__1)) + (d__2 = du[i__], abs( + d__2)) + (d__3 = dl[i__ - 1], abs(d__3)); + if (anorm < temp || disnan_(&temp)) { + anorm = temp; + } +/* L30: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + dlassq_(n, &d__[1], &c__1, &scale, &sum); + if (*n > 1) { + i__1 = *n - 1; + dlassq_(&i__1, &dl[1], &c__1, &scale, &sum); + i__1 = *n - 1; + dlassq_(&i__1, &du[1], &c__1, &scale, &sum); + } + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of DLANGT */ + +} /* dlangt_ */ + diff --git a/lapack-netlib/SRC/dlanhs.c b/lapack-netlib/SRC/dlanhs.c new file mode 100644 index 000000000..23f68d106 --- /dev/null +++ b/lapack-netlib/SRC/dlanhs.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 DLANHS 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 DLANHS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER LDA, N */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANHS 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 DLANHS */ +/* > \verbatim */ +/* > */ +/* > DLANHS = ( 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 DLANHS as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, DLANHS is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +doublereal dlanhs_(char *norm, integer *n, doublereal *a, integer *lda, + doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1; + + /* Local variables */ + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal colssq[2], 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.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + 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 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L30: */ + } + if (value < sum || disnan_(&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.; +/* 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__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&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.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of DLANHS */ + +} /* dlanhs_ */ + diff --git a/lapack-netlib/SRC/dlansb.c b/lapack-netlib/SRC/dlansb.c new file mode 100644 index 000000000..d1a1ccbd2 --- /dev/null +++ b/lapack-netlib/SRC/dlansb.c @@ -0,0 +1,713 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLANSB 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 DLANSB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, */ +/* WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER K, LDAB, N */ +/* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANSB 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 DLANSB */ +/* > \verbatim */ +/* > */ +/* > DLANSB = ( 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 DLANSB 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, DLANSB 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +doublereal dlansb_(char *norm, char *uplo, integer *n, integer *k, doublereal + *ab, integer *ldab, doublereal *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, l; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal colssq[2], 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.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + 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 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); + if (value < sum || disnan_(&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 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); + if (value < sum || disnan_(&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.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + 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 = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; +/* L50: */ + } + work[j] = sum + (d__1 = ab[*k + 1 + j * ab_dim1], abs(d__1)); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (d__1 = ab[j * ab_dim1 + 1], abs(d__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 = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; +/* L90: */ + } + if (value < sum || disnan_(&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.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + if (*k > 0) { + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = j - 1; + i__4 = f2cmin(i__3,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + dlassq_(&i__4, &ab[f2cmax(i__2,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L110: */ + } + l = *k + 1; + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = *n - j; + i__4 = f2cmin(i__3,*k); + dlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, colssq, & + colssq[1]); + dcombssq_(ssq, colssq); +/* L120: */ + } + l = 1; + } + ssq[1] *= 2; + } else { + l = 1; + } + +/* Sum diagonal */ + + colssq[0] = 0.; + colssq[1] = 1.; + dlassq_(n, &ab[l + ab_dim1], ldab, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of DLANSB */ + +} /* dlansb_ */ + diff --git a/lapack-netlib/SRC/dlansf.c b/lapack-netlib/SRC/dlansf.c new file mode 100644 index 000000000..2015d1b11 --- /dev/null +++ b/lapack-netlib/SRC/dlansf.c @@ -0,0 +1,1480 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLANSF 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 in RFP format. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLANSF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) */ + +/* CHARACTER NORM, TRANSR, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION A( 0: * ), WORK( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANSF 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 DLANSF */ +/* > \verbatim */ +/* > */ +/* > DLANSF = ( 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 DLANSF 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, DLANSF is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ + +/* ===================================================================== */ +doublereal dlansf_(char *norm, char *transr, char *uplo, integer *n, + doublereal *a, doublereal *work) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal temp; + integer i__, j, k, l; + doublereal s, scale; + extern logical lsame_(char *, char *); + doublereal value; + integer n1; + doublereal aa; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + 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.; + 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.; + 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 = (d__1 = a[i__ + j * lda], abs(d__1)); + if (value < temp || disnan_(&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 = (d__1 = a[i__ + j * lda], abs(d__1)); + if (value < temp || disnan_(&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 = (d__1 = a[i__ + j * lda], abs(d__1)); + if (value < temp || disnan_(&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 = (d__1 = a[i__ + j * lda], abs(d__1)); + if (value < temp || disnan_(&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.; + } + i__1 = k; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + if (i__ == k + k) { + goto L10; + } + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&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.; + } + for (j = k - 1; j >= 0; --j) { + s = 0.; + i__1 = j - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + if (j > 0) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* n is even */ + if (ilu == 0) { + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu = 1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + for (j = k - 1; j >= 0; --j) { + s = 0.; + i__1 = j - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&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.; + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,n1+i) */ + work[i__ + n1] += aa; + s += aa; + } + work[j] = s; + } +/* j=n1=k-1 is special */ + s = (d__1 = a[j * lda], abs(d__1)); +/* A(k-1,k-1) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__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.; + i__2 = j - k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(i,j-k) */ + work[i__] += aa; + s += aa; + } +/* i=j-k */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j-k,j-k) */ + s += aa; + work[j - k] += s; + ++i__; + s = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,j) */ + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&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.; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { +/* process */ + s = 0.; + i__2 = j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,i) */ + work[i__] += aa; + s += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__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 = (d__1 = a[i__ + j * lda], abs(d__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__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.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (d__1 = a[i__ + j * lda], abs(d__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.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* n is even */ + if (ilu == 0) { + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,i+k) */ + work[i__ + k] += aa; + s += aa; + } + work[j] = s; + } +/* j=k */ + aa = (d__1 = a[j * lda], abs(d__1)); +/* A(k,k) */ + s = aa; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__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.; + i__2 = j - 2 - k; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(i,j-k-1) */ + work[i__] += aa; + s += aa; + } +/* i=j-1-k */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j-k-1,j-k-1) */ + s += aa; + work[j - k - 1] += s; + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,j) */ + s = aa; + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,l) */ + work[l] += aa; + s += aa; + } + work[j] += s; + } +/* j=n */ + s = 0.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(i,k-1) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } +/* 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 = (d__1 = a[i__], abs(d__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.; + i__2 = j - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j-1,i) */ + work[i__] += aa; + s += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__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 = (d__1 = a[i__ + j * lda], abs(d__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__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.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (d__1 = a[i__ + j * lda], abs(d__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.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__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 || disnan_(&temp)) { + value = temp; + } + } + } + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + k = (*n + 1) / 2; + scale = 0.; + s = 1.; + 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; + dlassq_(&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; + dlassq_(&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; + dlassq_(&i__1, &a[k], &i__2, &scale, &s); +/* tri L at A(k,0) */ + i__1 = lda + 1; + dlassq_(&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; + dlassq_(&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) { + dlassq_(&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; + dlassq_(&k, a, &i__1, &scale, &s); +/* tri L at A(0,0) */ + i__1 = k - 1; + i__2 = lda + 1; + dlassq_(&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) { + dlassq_(&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) { + dlassq_(&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; + dlassq_(&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; + dlassq_(&i__1, &a[k * lda], &i__2, &scale, &s); +/* tri U at A(0,k) */ + i__1 = lda + 1; + dlassq_(&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) { + dlassq_(&j, &a[j * lda], &c__1, &scale, &s); +/* U at A(0,0) */ + } + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + dlassq_(&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; + dlassq_(&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; + dlassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + i__1 = k - 1; + i__2 = lda + 1; + dlassq_(&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; + dlassq_(&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; + dlassq_(&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; + dlassq_(&k, &a[k + 1], &i__1, &scale, &s); +/* tri L at A(k+1,0) */ + i__1 = lda + 1; + dlassq_(&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; + dlassq_(&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) { + dlassq_(&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; + dlassq_(&k, &a[1], &i__1, &scale, &s); +/* tri L at A(1,0) */ + i__1 = lda + 1; + dlassq_(&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) { + dlassq_(&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) { + dlassq_(&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; + dlassq_(&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; + dlassq_(&k, &a[(k + 1) * lda], &i__1, &scale, &s); +/* tri U at A(0,k+1) */ + i__1 = lda + 1; + dlassq_(&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) { + dlassq_(&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) { + dlassq_(&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; + dlassq_(&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; + dlassq_(&k, &a[lda], &i__1, &scale, &s); +/* tri L at A(0,1) */ + i__1 = lda + 1; + dlassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + } + } + } + value = scale * sqrt(s); + } + + ret_val = value; + return ret_val; + +/* End of DLANSF */ + +} /* dlansf_ */ + diff --git a/lapack-netlib/SRC/dlansp.c b/lapack-netlib/SRC/dlansp.c new file mode 100644 index 000000000..bf3cc132a --- /dev/null +++ b/lapack-netlib/SRC/dlansp.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 DLANSP 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 DLANSP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANSP 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 DLANSP */ +/* > \verbatim */ +/* > */ +/* > DLANSP = ( 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 DLANSP 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, DLANSP is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the symmetric matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION 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 doubleOTHERauxiliary */ + +/* ===================================================================== */ +doublereal dlansp_(char *norm, char *uplo, integer *n, doublereal *ap, + doublereal *work) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, k; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal colssq[2], 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.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + 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 = (d__1 = ap[i__], abs(d__1)); + if (value < sum || disnan_(&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 = (d__1 = ap[i__], abs(d__1)); + if (value < sum || disnan_(&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.; + k = 1; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = (d__1 = ap[k], abs(d__1)); + sum += absa; + work[i__] += absa; + ++k; +/* L50: */ + } + work[j] = sum + (d__1 = ap[k], abs(d__1)); + ++k; +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (d__1 = ap[k], abs(d__1)); + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = (d__1 = ap[k], abs(d__1)); + sum += absa; + work[i__] += absa; + ++k; +/* L90: */ + } + if (value < sum || disnan_(&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.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + k = 2; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = j - 1; + dlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k += j; +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *n - j; + dlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L120: */ + } + } + ssq[1] *= 2; + +/* Sum diagonal */ + + k = 1; + colssq[0] = 0.; + colssq[1] = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ap[k] != 0.) { + absa = (d__1 = ap[k], abs(d__1)); + if (colssq[0] < absa) { +/* Computing 2nd power */ + d__1 = colssq[0] / absa; + colssq[1] = colssq[1] * (d__1 * d__1) + 1.; + colssq[0] = absa; + } else { +/* Computing 2nd power */ + d__1 = absa / colssq[0]; + colssq[1] += d__1 * d__1; + } + } + if (lsame_(uplo, "U")) { + k = k + i__ + 1; + } else { + k = k + *n - i__ + 1; + } +/* L130: */ + } + dcombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of DLANSP */ + +} /* dlansp_ */ + diff --git a/lapack-netlib/SRC/dlanst.c b/lapack-netlib/SRC/dlanst.c new file mode 100644 index 000000000..739c74638 --- /dev/null +++ b/lapack-netlib/SRC/dlanst.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 DLANST 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 DLANST + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) */ + +/* CHARACTER NORM */ +/* INTEGER N */ +/* DOUBLE PRECISION D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLANST 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 DLANST */ +/* > \verbatim */ +/* > */ +/* > DLANST = ( 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 DLANST as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, DLANST is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION 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 */ + +/* ===================================================================== */ +doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e) +{ + /* System generated locals */ + integer i__1; + doublereal ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__; + doublereal scale; + extern logical lsame_(char *, char *); + doublereal anorm; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + doublereal 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.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + anorm = (d__1 = d__[*n], abs(d__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + sum = (d__1 = e[i__], abs(d__1)); + if (anorm < sum || disnan_(&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 = (d__1 = e[*n - 1], abs(d__1)) + (d__2 = d__[*n], abs(d__2)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2) + ) + (d__3 = e[i__ - 1], abs(d__3)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } +/* L20: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + if (*n > 1) { + i__1 = *n - 1; + dlassq_(&i__1, &e[1], &c__1, &scale, &sum); + sum *= 2; + } + dlassq_(n, &d__[1], &c__1, &scale, &sum); + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of DLANST */ + +} /* dlanst_ */ +