From 083bc1764bcae99f2083bff57c587c3e14601a16 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 23 Feb 2022 00:15:47 +0100 Subject: [PATCH] Add C versions as fallback --- lapack-netlib/SRC/claswlq.c | 670 +++++++++ lapack-netlib/SRC/claswp.c | 606 ++++++++ lapack-netlib/SRC/clasyf.c | 1422 +++++++++++++++++++ lapack-netlib/SRC/clasyf_aa.c | 960 +++++++++++++ lapack-netlib/SRC/clasyf_rk.c | 1594 +++++++++++++++++++++ lapack-netlib/SRC/clasyf_rook.c | 1520 ++++++++++++++++++++ lapack-netlib/SRC/clatbs.c | 1633 ++++++++++++++++++++++ lapack-netlib/SRC/clatdf.c | 793 +++++++++++ lapack-netlib/SRC/clatps.c | 1597 +++++++++++++++++++++ lapack-netlib/SRC/clatrd.c | 857 ++++++++++++ lapack-netlib/SRC/clatrs.c | 1586 +++++++++++++++++++++ lapack-netlib/SRC/clatrz.c | 609 ++++++++ lapack-netlib/SRC/clatsqr.c | 670 +++++++++ lapack-netlib/SRC/claunhr_col_getrfnp.c | 656 +++++++++ lapack-netlib/SRC/claunhr_col_getrfnp2.c | 728 ++++++++++ lapack-netlib/SRC/clauu2.c | 625 +++++++++ lapack-netlib/SRC/clauum.c | 642 +++++++++ lapack-netlib/SRC/cpbcon.c | 667 +++++++++ lapack-netlib/SRC/cpbequ.c | 636 +++++++++ lapack-netlib/SRC/cpbrfs.c | 932 ++++++++++++ lapack-netlib/SRC/cpbstf.c | 759 ++++++++++ lapack-netlib/SRC/cpbsv.c | 622 ++++++++ lapack-netlib/SRC/cpbsvx.c | 1004 +++++++++++++ lapack-netlib/SRC/cpbtf2.c | 681 +++++++++ lapack-netlib/SRC/cpbtrf.c | 921 ++++++++++++ lapack-netlib/SRC/cpbtrs.c | 619 ++++++++ lapack-netlib/SRC/cpftrf.c | 887 ++++++++++++ lapack-netlib/SRC/cpftri.c | 847 +++++++++++ lapack-netlib/SRC/cpftrs.c | 689 +++++++++ lapack-netlib/SRC/cpocon.c | 650 +++++++++ lapack-netlib/SRC/cpoequ.c | 603 ++++++++ lapack-netlib/SRC/cpoequb.c | 618 ++++++++ lapack-netlib/SRC/cporfs.c | 913 ++++++++++++ lapack-netlib/SRC/cporfsx.c | 381 +++++ lapack-netlib/SRC/cposv.c | 585 ++++++++ lapack-netlib/SRC/cposvx.c | 932 ++++++++++++ lapack-netlib/SRC/cposvxx.c | 1103 +++++++++++++++ lapack-netlib/SRC/cpotf2.c | 664 +++++++++ lapack-netlib/SRC/cpotrf.c | 672 +++++++++ lapack-netlib/SRC/cpotrf2.c | 639 +++++++++ lapack-netlib/SRC/cpotri.c | 550 ++++++++ lapack-netlib/SRC/cpotrs.c | 595 ++++++++ lapack-netlib/SRC/cppcon.c | 644 +++++++++ lapack-netlib/SRC/cppequ.c | 637 +++++++++ lapack-netlib/SRC/cpprfs.c | 897 ++++++++++++ lapack-netlib/SRC/cppsv.c | 594 ++++++++ lapack-netlib/SRC/cppsvx.c | 931 ++++++++++++ lapack-netlib/SRC/cpptrf.c | 653 +++++++++ lapack-netlib/SRC/cpptri.c | 599 ++++++++ lapack-netlib/SRC/cpptrs.c | 599 ++++++++ lapack-netlib/SRC/cpstf2.c | 878 ++++++++++++ lapack-netlib/SRC/cpstrf.c | 959 +++++++++++++ lapack-netlib/SRC/cptcon.c | 614 ++++++++ lapack-netlib/SRC/cpteqr.c | 667 +++++++++ lapack-netlib/SRC/cptrfs.c | 1027 ++++++++++++++ lapack-netlib/SRC/cptsv.c | 562 ++++++++ lapack-netlib/SRC/cptsvx.c | 750 ++++++++++ lapack-netlib/SRC/cpttrf.c | 632 +++++++++ lapack-netlib/SRC/cpttrs.c | 613 ++++++++ lapack-netlib/SRC/cptts2.c | 744 ++++++++++ lapack-netlib/SRC/crot.c | 589 ++++++++ lapack-netlib/SRC/cspcon.c | 627 +++++++++ lapack-netlib/SRC/cspmv.c | 867 ++++++++++++ lapack-netlib/SRC/cspr.c | 768 ++++++++++ lapack-netlib/SRC/csprfs.c | 910 ++++++++++++ lapack-netlib/SRC/cspsv.c | 614 ++++++++ lapack-netlib/SRC/cspsvx.c | 791 +++++++++++ lapack-netlib/SRC/csptrf.c | 1178 ++++++++++++++++ lapack-netlib/SRC/csptri.c | 931 ++++++++++++ lapack-netlib/SRC/csptrs.c | 931 ++++++++++++ lapack-netlib/SRC/csrscl.c | 552 ++++++++ lapack-netlib/SRC/cstedc.c | 934 +++++++++++++ lapack-netlib/SRC/cstegr.c | 698 +++++++++ lapack-netlib/SRC/cstein.c | 913 ++++++++++++ lapack-netlib/SRC/cstemr.c | 1231 ++++++++++++++++ lapack-netlib/SRC/csteqr.c | 1048 ++++++++++++++ lapack-netlib/SRC/csycon.c | 633 +++++++++ lapack-netlib/SRC/csycon_3.c | 675 +++++++++ lapack-netlib/SRC/csycon_rook.c | 647 +++++++++ lapack-netlib/SRC/csyconv.c | 811 +++++++++++ lapack-netlib/SRC/csyconvf.c | 974 +++++++++++++ lapack-netlib/SRC/csyconvf_rook.c | 964 +++++++++++++ lapack-netlib/SRC/csyequb.c | 873 ++++++++++++ lapack-netlib/SRC/csymv.c | 868 ++++++++++++ lapack-netlib/SRC/csyr.c | 719 ++++++++++ lapack-netlib/SRC/csyrfs.c | 926 ++++++++++++ lapack-netlib/SRC/csyrfsx.c | 381 +++++ lapack-netlib/SRC/csysv.c | 671 +++++++++ lapack-netlib/SRC/csysv_aa.c | 651 +++++++++ lapack-netlib/SRC/csysv_aa_2stage.c | 678 +++++++++ lapack-netlib/SRC/csysv_rk.c | 716 ++++++++++ lapack-netlib/SRC/csysv_rook.c | 692 +++++++++ lapack-netlib/SRC/csysvx.c | 844 +++++++++++ lapack-netlib/SRC/csysvxx.c | 1125 +++++++++++++++ lapack-netlib/SRC/csyswapr.c | 617 ++++++++ lapack-netlib/SRC/csytf2_rk.c | 1565 +++++++++++++++++++++ 96 files changed, 77949 insertions(+) create mode 100644 lapack-netlib/SRC/claswlq.c create mode 100644 lapack-netlib/SRC/claswp.c create mode 100644 lapack-netlib/SRC/clasyf.c create mode 100644 lapack-netlib/SRC/clasyf_aa.c create mode 100644 lapack-netlib/SRC/clasyf_rk.c create mode 100644 lapack-netlib/SRC/clasyf_rook.c create mode 100644 lapack-netlib/SRC/clatbs.c create mode 100644 lapack-netlib/SRC/clatdf.c create mode 100644 lapack-netlib/SRC/clatps.c create mode 100644 lapack-netlib/SRC/clatrd.c create mode 100644 lapack-netlib/SRC/clatrs.c create mode 100644 lapack-netlib/SRC/clatrz.c create mode 100644 lapack-netlib/SRC/clatsqr.c create mode 100644 lapack-netlib/SRC/claunhr_col_getrfnp.c create mode 100644 lapack-netlib/SRC/claunhr_col_getrfnp2.c create mode 100644 lapack-netlib/SRC/clauu2.c create mode 100644 lapack-netlib/SRC/clauum.c create mode 100644 lapack-netlib/SRC/cpbcon.c create mode 100644 lapack-netlib/SRC/cpbequ.c create mode 100644 lapack-netlib/SRC/cpbrfs.c create mode 100644 lapack-netlib/SRC/cpbstf.c create mode 100644 lapack-netlib/SRC/cpbsv.c create mode 100644 lapack-netlib/SRC/cpbsvx.c create mode 100644 lapack-netlib/SRC/cpbtf2.c create mode 100644 lapack-netlib/SRC/cpbtrf.c create mode 100644 lapack-netlib/SRC/cpbtrs.c create mode 100644 lapack-netlib/SRC/cpftrf.c create mode 100644 lapack-netlib/SRC/cpftri.c create mode 100644 lapack-netlib/SRC/cpftrs.c create mode 100644 lapack-netlib/SRC/cpocon.c create mode 100644 lapack-netlib/SRC/cpoequ.c create mode 100644 lapack-netlib/SRC/cpoequb.c create mode 100644 lapack-netlib/SRC/cporfs.c create mode 100644 lapack-netlib/SRC/cporfsx.c create mode 100644 lapack-netlib/SRC/cposv.c create mode 100644 lapack-netlib/SRC/cposvx.c create mode 100644 lapack-netlib/SRC/cposvxx.c create mode 100644 lapack-netlib/SRC/cpotf2.c create mode 100644 lapack-netlib/SRC/cpotrf.c create mode 100644 lapack-netlib/SRC/cpotrf2.c create mode 100644 lapack-netlib/SRC/cpotri.c create mode 100644 lapack-netlib/SRC/cpotrs.c create mode 100644 lapack-netlib/SRC/cppcon.c create mode 100644 lapack-netlib/SRC/cppequ.c create mode 100644 lapack-netlib/SRC/cpprfs.c create mode 100644 lapack-netlib/SRC/cppsv.c create mode 100644 lapack-netlib/SRC/cppsvx.c create mode 100644 lapack-netlib/SRC/cpptrf.c create mode 100644 lapack-netlib/SRC/cpptri.c create mode 100644 lapack-netlib/SRC/cpptrs.c create mode 100644 lapack-netlib/SRC/cpstf2.c create mode 100644 lapack-netlib/SRC/cpstrf.c create mode 100644 lapack-netlib/SRC/cptcon.c create mode 100644 lapack-netlib/SRC/cpteqr.c create mode 100644 lapack-netlib/SRC/cptrfs.c create mode 100644 lapack-netlib/SRC/cptsv.c create mode 100644 lapack-netlib/SRC/cptsvx.c create mode 100644 lapack-netlib/SRC/cpttrf.c create mode 100644 lapack-netlib/SRC/cpttrs.c create mode 100644 lapack-netlib/SRC/cptts2.c create mode 100644 lapack-netlib/SRC/crot.c create mode 100644 lapack-netlib/SRC/cspcon.c create mode 100644 lapack-netlib/SRC/cspmv.c create mode 100644 lapack-netlib/SRC/cspr.c create mode 100644 lapack-netlib/SRC/csprfs.c create mode 100644 lapack-netlib/SRC/cspsv.c create mode 100644 lapack-netlib/SRC/cspsvx.c create mode 100644 lapack-netlib/SRC/csptrf.c create mode 100644 lapack-netlib/SRC/csptri.c create mode 100644 lapack-netlib/SRC/csptrs.c create mode 100644 lapack-netlib/SRC/csrscl.c create mode 100644 lapack-netlib/SRC/cstedc.c create mode 100644 lapack-netlib/SRC/cstegr.c create mode 100644 lapack-netlib/SRC/cstein.c create mode 100644 lapack-netlib/SRC/cstemr.c create mode 100644 lapack-netlib/SRC/csteqr.c create mode 100644 lapack-netlib/SRC/csycon.c create mode 100644 lapack-netlib/SRC/csycon_3.c create mode 100644 lapack-netlib/SRC/csycon_rook.c create mode 100644 lapack-netlib/SRC/csyconv.c create mode 100644 lapack-netlib/SRC/csyconvf.c create mode 100644 lapack-netlib/SRC/csyconvf_rook.c create mode 100644 lapack-netlib/SRC/csyequb.c create mode 100644 lapack-netlib/SRC/csymv.c create mode 100644 lapack-netlib/SRC/csyr.c create mode 100644 lapack-netlib/SRC/csyrfs.c create mode 100644 lapack-netlib/SRC/csyrfsx.c create mode 100644 lapack-netlib/SRC/csysv.c create mode 100644 lapack-netlib/SRC/csysv_aa.c create mode 100644 lapack-netlib/SRC/csysv_aa_2stage.c create mode 100644 lapack-netlib/SRC/csysv_rk.c create mode 100644 lapack-netlib/SRC/csysv_rook.c create mode 100644 lapack-netlib/SRC/csysvx.c create mode 100644 lapack-netlib/SRC/csysvxx.c create mode 100644 lapack-netlib/SRC/csyswapr.c create mode 100644 lapack-netlib/SRC/csytf2_rk.c diff --git a/lapack-netlib/SRC/claswlq.c b/lapack-netlib/SRC/claswlq.c new file mode 100644 index 000000000..0baccc9a1 --- /dev/null +++ b/lapack-netlib/SRC/claswlq.c @@ -0,0 +1,670 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLASWLQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, */ +/* LWORK, INFO) */ + +/* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK */ +/* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLASWLQ computes a blocked Tall-Skinny LQ factorization of */ +/* > a complex M-by-N matrix A for M <= N: */ +/* > */ +/* > A = ( L 0 ) * Q, */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a n-by-N orthogonal matrix, stored on exit in an implicit */ +/* > form in the elements above the digonal of the array A and in */ +/* > the elemenst of the array T; */ +/* > L is an lower-triangular M-by-M matrix stored on exit in */ +/* > the elements on and below the diagonal of the array A. */ +/* > 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= M >= 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,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the elements on and below the diagonal */ +/* > of the array contain the N-by-N lower triangular matrix L; */ +/* > the elements above the diagonal represent Q by the rows */ +/* > of blocked V (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] T */ +/* > \verbatim */ +/* > T is COMPLEX array, */ +/* > dimension (LDT, N * Number_of_row_blocks) */ +/* > where Number_of_row_blocks = CEIL((N-M)/(NB-M)) */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. */ +/* > See Further Details below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > */ +/* > \endverbatim */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. LWORK >= MB*M. */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > */ +/* > \endverbatim */ +/* > \param[out] 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 claswlq_(integer *m, integer *n, integer *mb, integer * + nb, complex *a, integer *lda, complex *t, integer *ldt, complex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, ii, kk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cgelqt_( + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *), ctplqt_(integer *, integer *, + integer *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *); + logical lquery; + integer ctr; + + +/* -- LAPACK computational routine (version 3.9.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- */ +/* 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; + --work; + + /* Function Body */ + *info = 0; + + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n < *m) { + *info = -2; + } else if (*mb < 1 || *mb > *m && *m > 0) { + *info = -3; + } else if (*nb <= *m) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldt < *mb) { + *info = -8; + } else if (*lwork < *m * *mb && ! lquery) { + *info = -10; + } + if (*info == 0) { + i__1 = *mb * *m; + work[1].r = (real) i__1, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLASWLQ", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* The LQ Decomposition */ + + if (*m >= *n || *nb <= *m || *nb >= *n) { + cgelqt_(m, n, mb, &a[a_offset], lda, &t[t_offset], ldt, &work[1], + info); + return 0; + } + + kk = (*n - *m) % (*nb - *m); + ii = *n - kk + 1; + +/* Compute the LQ factorization of the first block A(1:M,1:NB) */ + + cgelqt_(m, nb, mb, &a[a_dim1 + 1], lda, &t[t_offset], ldt, &work[1], info) + ; + ctr = 1; + + i__1 = ii - *nb + *m; + i__2 = *nb - *m; + for (i__ = *nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block A(1:M,I:I+NB-M) */ + + i__3 = *nb - *m; + ctplqt_(m, &i__3, &c__0, mb, &a[a_dim1 + 1], lda, &a[i__ * a_dim1 + 1] + , lda, &t[(ctr * *m + 1) * t_dim1 + 1], ldt, &work[1], info); + ++ctr; + } + +/* Compute the QR factorization of the last block A(1:M,II:N) */ + + if (ii <= *n) { + ctplqt_(m, &kk, &c__0, mb, &a[a_dim1 + 1], lda, &a[ii * a_dim1 + 1], + lda, &t[(ctr * *m + 1) * t_dim1 + 1], ldt, &work[1], info); + } + + i__2 = *m * *mb; + work[1].r = (real) i__2, work[1].i = 0.f; + return 0; + +/* End of CLASWLQ */ + +} /* claswlq_ */ + diff --git a/lapack-netlib/SRC/claswp.c b/lapack-netlib/SRC/claswp.c new file mode 100644 index 000000000..9eb8a70b3 --- /dev/null +++ b/lapack-netlib/SRC/claswp.c @@ -0,0 +1,606 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLASWP performs a series of row interchanges on a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLASWP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) */ + +/* INTEGER INCX, K1, K2, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLASWP performs a series of row interchanges on the matrix A. */ +/* > One row interchange is initiated for each of rows K1 through K2 of A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the matrix of column dimension N to which the row */ +/* > interchanges will be applied. */ +/* > On exit, the permuted matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K1 */ +/* > \verbatim */ +/* > K1 is INTEGER */ +/* > The first element of IPIV for which a row interchange will */ +/* > be done. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K2 */ +/* > \verbatim */ +/* > K2 is INTEGER */ +/* > (K2-K1+1) is the number of elements of IPIV for which a row */ +/* > interchange will be done. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) */ +/* > The vector of pivot indices. Only the elements in positions */ +/* > K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed. */ +/* > IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be */ +/* > interchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of IPIV. If INCX */ +/* > is negative, the pivots are applied in reverse order. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Modified by */ +/* > R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int claswp_(integer *n, complex *a, integer *lda, integer * + k1, integer *k2, integer *ipiv, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + complex temp; + integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows */ +/* K1 through K2. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + + /* Function Body */ + if (*incx > 0) { + ix0 = *k1; + i1 = *k1; + i2 = *k2; + inc = 1; + } else if (*incx < 0) { + ix0 = *k1 + (*k1 - *k2) * *incx; + i1 = *k2; + i2 = *k1; + inc = -1; + } else { + return 0; + } + + n32 = *n / 32 << 5; + if (n32 != 0) { + i__1 = n32; + for (j = 1; j <= i__1; j += 32) { + ix = ix0; + i__2 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) + { + ip = ipiv[ix]; + if (ip != i__) { + i__4 = j + 31; + for (k = j; k <= i__4; ++k) { + i__5 = i__ + k * a_dim1; + temp.r = a[i__5].r, temp.i = a[i__5].i; + i__5 = i__ + k * a_dim1; + i__6 = ip + k * a_dim1; + a[i__5].r = a[i__6].r, a[i__5].i = a[i__6].i; + i__5 = ip + k * a_dim1; + a[i__5].r = temp.r, a[i__5].i = temp.i; +/* L10: */ + } + } + ix += *incx; +/* L20: */ + } +/* L30: */ + } + } + if (n32 != *n) { + ++n32; + ix = ix0; + i__1 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { + ip = ipiv[ix]; + if (ip != i__) { + i__2 = *n; + for (k = n32; k <= i__2; ++k) { + i__4 = i__ + k * a_dim1; + temp.r = a[i__4].r, temp.i = a[i__4].i; + i__4 = i__ + k * a_dim1; + i__5 = ip + k * a_dim1; + a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i; + i__4 = ip + k * a_dim1; + a[i__4].r = temp.r, a[i__4].i = temp.i; +/* L40: */ + } + } + ix += *incx; +/* L50: */ + } + } + + return 0; + +/* End of CLASWP */ + +} /* claswp_ */ + diff --git a/lapack-netlib/SRC/clasyf.c b/lapack-netlib/SRC/clasyf.c new file mode 100644 index 000000000..ccde5c92a --- /dev/null +++ b/lapack-netlib/SRC/clasyf.c @@ -0,0 +1,1422 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman d +iagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLASYF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLASYF computes a partial factorization of a complex symmetric matrix */ +/* > A using the Bunch-Kaufman diagonal pivoting method. The partial */ +/* > factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > Note that U**T denotes the transpose of U. */ +/* > */ +/* > CLASYF is an auxiliary routine called by CSYTRF. It uses blocked code */ +/* > (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */ +/* > A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, A contains details of the partial factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = IPIV(k-1) < 0, then rows and columns */ +/* > k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = IPIV(k+1) < 0, then rows and columns */ +/* > k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) */ +/* > is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int clasyf_(char *uplo, integer *n, integer *nb, integer *kb, + complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3; + + /* Local variables */ + integer imax, jmax, j, k; + complex t; + real alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), cgemm_(char *, char *, integer *, integer *, integer * + , complex *, complex *, integer *, complex *, integer *, complex * + , complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), ccopy_(integer *, complex *, integer *, + complex *, integer *), cswap_(integer *, complex *, integer *, + complex *, integer *); + integer kstep; + complex r1, d11, d21, d22; + integer jb, jj, kk, jp, kp; + real absakk; + integer kw; + extern integer icamax_(integer *, complex *, integer *); + real colmax, rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + +/* KW is the column of W which corresponds to column K of A */ + + k = *n; +L10: + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + +/* Copy column K of A to column KW of W and update it */ + + ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + } + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[k + kw * + w_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + kw * w_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column KW-1 of W and update it */ + + ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + jmax + (kw - 1) * w_dim1]), abs(r__2)); + if (imax > 1) { + i__1 = imax - 1; + jmax = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + (kw - 1) * w_dim1; + r__3 = rowmax, r__4 = (r__1 = w[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&w[jmax + (kw - 1) * w_dim1]), abs( + r__2)); + rowmax = f2cmax(r__3,r__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (kw - 1) * w_dim1; + if ((r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + imax + (kw - 1) * w_dim1]), abs(r__2)) >= alpha * + rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KKW of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kk - 1 - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + +/* Interchange rows KK and KP in last K+1 to N columns of A */ +/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column kw of W now holds */ + +/* W(kw) = U(k)*D(k), */ + +/* where U(k) is the k-th column of U */ + +/* Store subdiag. elements of column U(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* NOTE: Diagonal element U(k,k) is a UNIT element */ +/* and not stored. */ +/* A(k,k) := D(k,k) = W(k,kw) */ +/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */ + + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = k - 1; + cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + + } else { + +/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */ + +/* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */ +/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */ +/* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */ +/* block and not stored. */ +/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */ +/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */ +/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */ + + if (k > 2) { + +/* Compose the columns of the inverse of 2-by-2 pivot */ +/* block D in the following way to reduce the number */ +/* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by */ +/* this inverse */ + +/* D**(-1) = ( d11 d21 )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */ +/* ( (-d21 ) ( d11 ) ) */ + +/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */ + +/* * ( ( d22/d21 ) ( -1 ) ) = */ +/* ( ( -1 ) ( d11/d21 ) ) */ + +/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = D21 * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + kw * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + +/* Update elements in columns A(k-1) and A(k) as */ +/* dot products of rows of ( W(kw-1) W(kw) ) and columns */ +/* of D**(-1) */ + + c_div(&q__1, &t, &d21); + d21.r = q__1.r, d21.i = q__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L20: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + i__2 = j - 1; + i__3 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, &a[( + k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, + &c_b1, &a[j * a_dim1 + 1], lda); +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n looping backwards from k+1 to n */ + + j = k + 1; +L60: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + ++j; + } +/* (NOTE: Here, J is used to determine row length. Length N-J+1 */ +/* of the rows to swap back doesn't include diagonal element) */ + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[k + k * + w_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + k * w_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * + w_dim1], &c__1); + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + jmax + (k + 1) * w_dim1]), abs(r__2)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + i__1 = jmax + (k + 1) * w_dim1; + r__3 = rowmax, r__4 = (r__1 = w[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&w[jmax + (k + 1) * w_dim1]), abs( + r__2)); + rowmax = f2cmax(r__3,r__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (k + 1) * w_dim1; + if ((r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + imax + (k + 1) * w_dim1]), abs(r__2)) >= alpha * + rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + + k * w_dim1], &c__1); + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k + kstep - 1; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KK of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - kk - 1; + ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + +/* Interchange rows KK and KP in first K-1 columns of A */ +/* (columns K (or K and K+1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k), */ + +/* where L(k) is the k-th column of L */ + +/* Store subdiag. elements of column L(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element L(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,k) */ +/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = *n - k; + cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + +/* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */ +/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */ +/* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */ +/* block and not stored) */ +/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */ +/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */ +/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */ + + if (k < *n - 1) { + +/* Compose the columns of the inverse of 2-by-2 pivot */ +/* block D in the following way to reduce the number */ +/* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by */ +/* this inverse */ + +/* D**(-1) = ( d11 d21 )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */ +/* ( (-d21 ) ( d11 ) ) */ + +/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */ + +/* * ( ( d22/d21 ) ( -1 ) ) = */ +/* ( ( -1 ) ( d11/d21 ) ) */ + +/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = D21 * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k + k * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + c_div(&q__1, &t, &d21); + d21.r = q__1.r, d21.i = q__1.i; + +/* Update elements in columns A(k) and A(k+1) as */ +/* dot products of rows of ( W(k) W(k+1) ) and columns */ +/* of D**(-1) */ + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L80: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ + + j = k - 1; +L120: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + --j; + } +/* (NOTE: Here, J is used to determine row length. Length J */ +/* of the rows to swap back doesn't include diagonal element) */ + --j; + if (jp != jj && j >= 1) { + cswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of CLASYF */ + +} /* clasyf_ */ + diff --git a/lapack-netlib/SRC/clasyf_aa.c b/lapack-netlib/SRC/clasyf_aa.c new file mode 100644 index 000000000..60f46c276 --- /dev/null +++ b/lapack-netlib/SRC/clasyf_aa.c @@ -0,0 +1,960 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLASYF_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLASYF_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, */ +/* H, LDH, WORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER J1, M, NB, LDA, LDH */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), H( LDH, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATRF_AA factorizes a panel of a complex symmetric matrix A using */ +/* > the Aasen's algorithm. The panel consists of a set of NB rows of A */ +/* > when UPLO is U, or a set of NB columns when UPLO is L. */ +/* > */ +/* > In order to factorize the panel, the Aasen's algorithm requires the */ +/* > last row, or column, of the previous panel. The first row, or column, */ +/* > of A is set to be the first row, or column, of an identity matrix, */ +/* > which is used to factorize the first panel. */ +/* > */ +/* > The resulting J-th row of U, or J-th column of L, is stored in the */ +/* > (J-1)-th row, or column, of A (without the unit diagonals), while */ +/* > the diagonal and subdiagonal of A are overwritten by those of T. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The location of the first row, or column, of the panel */ +/* > within the submatrix of A, passed to this routine, e.g., */ +/* > when called by CSYTRF_AA, for the first panel, J1 is 1, */ +/* > while for the remaining panels, J1 is 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the submatrix. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The dimension of the panel to be facotorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,M) for */ +/* > the first panel, while dimension (LDA,M+1) for the */ +/* > remaining panels. */ +/* > */ +/* > On entry, A contains the last row, or column, of */ +/* > the previous panel, and the trailing submatrix of A */ +/* > to be factorized, except for the first panel, only */ +/* > the panel is passed. */ +/* > */ +/* > On exit, the leading panel is factorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (M) */ +/* > Details of the row and column interchanges, */ +/* > the row and column k were interchanged with the row and */ +/* > column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX workspace, dimension (LDH,NB). */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the workspace H. LDH >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX workspace, dimension (M). */ +/* > \endverbatim */ +/* > */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int clasyf_aa_(char *uplo, integer *j1, integer *m, integer + *nb, complex *a, integer *lda, integer *ipiv, complex *h__, integer * + ldh, complex *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, h_dim1, h_offset, i__1, i__2; + complex q__1; + + /* Local variables */ + integer j, k; + complex alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), ccopy_(integer *, complex *, integer *, + complex *, integer *), cswap_(integer *, complex *, integer *, + complex *, integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + integer i1, k1, i2, mj; + extern integer icamax_(integer *, complex *, integer *); + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *); + complex piv; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --work; + + /* Function Body */ + j = 1; + +/* K1 is the first column of the panel to be factorized */ +/* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks */ + + k1 = 2 - *j1 + 1; + + if (lsame_(uplo, "U")) { + +/* ..................................................... */ +/* Factorize A as U**T*D*U using the upper triangle of A */ +/* ..................................................... */ + +L10: + if (j > f2cmin(*m,*nb)) { + goto L20; + } + +/* K is the column to be factorized */ +/* when being called from CSYTRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:M, J) := A(J, J:M) - H(J:M, 1:(J-1)) * L(J1:(J-1), J), */ +/* where H(J:M, J) has been initialized to be A(J, J:M) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + cgemv_("No transpose", &mj, &i__1, &c_b6, &h__[j + k1 * h_dim1], + ldh, &a[j * a_dim1 + 1], &c__1, &c_b8, &h__[j + j * + h_dim1], &c__1); + } + +/* Copy H(i:M, i) into WORK */ + + ccopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J-1, J:M) * T(J-1,J), */ +/* where A(J-1, J) stores T(J-1, J) and A(J-2, J:M) stores U(J-1, J:M) */ + + i__1 = k - 1 + j * a_dim1; + q__1.r = -a[i__1].r, q__1.i = -a[i__1].i; + alpha.r = q__1.r, alpha.i = q__1.i; + caxpy_(&mj, &alpha, &a[k - 2 + j * a_dim1], lda, &work[1], &c__1); + } + +/* Set A(J, J) = T(J, J) */ + + i__1 = k + j * a_dim1; + a[i__1].r = work[1].r, a[i__1].i = work[1].i; + + if (j < *m) { + +/* Compute WORK(2:M) = T(J, J) L(J, (J+1):M) */ +/* where A(J, J) stores T(J, J) and A(J-1, (J+1):M) stores U(J, (J+1):M) */ + + if (k > 1) { + i__1 = k + j * a_dim1; + q__1.r = -a[i__1].r, q__1.i = -a[i__1].i; + alpha.r = q__1.r, alpha.i = q__1.i; + i__1 = *m - j; + caxpy_(&i__1, &alpha, &a[k - 1 + (j + 1) * a_dim1], lda, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:M)|) */ + + i__1 = *m - j; + i2 = icamax_(&i__1, &work[2], &c__1) + 1; + i__1 = i2; + piv.r = work[i__1].r, piv.i = work[i__1].i; + +/* Apply symmetric pivot */ + + if (i2 != 2 && (piv.r != 0.f || piv.i != 0.)) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + i__1 = i2; + i__2 = i1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + i__1 = i1; + work[i__1].r = piv.r, work[i__1].i = piv.i; + +/* Swap A(I1, I1+1:M) with A(I1+1:M, I2) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + cswap_(&i__1, &a[*j1 + i1 - 1 + (i1 + 1) * a_dim1], lda, &a[* + j1 + i1 + i2 * a_dim1], &c__1); + +/* Swap A(I1, I2+1:M) with A(I2, I2+1:M) */ + + if (i2 < *m) { + i__1 = *m - i2; + cswap_(&i__1, &a[*j1 + i1 - 1 + (i2 + 1) * a_dim1], lda, & + a[*j1 + i2 - 1 + (i2 + 1) * a_dim1], lda); + } + +/* Swap A(I1, I1) with A(I2,I2) */ + + i__1 = i1 + *j1 - 1 + i1 * a_dim1; + piv.r = a[i__1].r, piv.i = a[i__1].i; + i__1 = *j1 + i1 - 1 + i1 * a_dim1; + i__2 = *j1 + i2 - 1 + i2 * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = *j1 + i2 - 1 + i2 * a_dim1; + a[i__1].r = piv.r, a[i__1].i = piv.i; + +/* Swap H(I1, 1:J1) with H(I2, 1:J1) */ + + i__1 = i1 - 1; + cswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + cswap_(&i__1, &a[i1 * a_dim1 + 1], &c__1, &a[i2 * a_dim1 + + 1], &c__1); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J, J+1) = T(J, J+1) */ + + i__1 = k + (j + 1) * a_dim1; + a[i__1].r = work[2].r, a[i__1].i = work[2].i; + + if (j < *nb) { + +/* Copy A(J+1:M, J+1) into H(J:M, J), */ + + i__1 = *m - j; + ccopy_(&i__1, &a[k + 1 + (j + 1) * a_dim1], lda, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1) */ + + if (j < *m - 1) { + i__1 = k + (j + 1) * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + c_div(&q__1, &c_b8, &a[k + (j + 1) * a_dim1]); + alpha.r = q__1.r, alpha.i = q__1.i; + i__1 = *m - j - 1; + ccopy_(&i__1, &work[3], &c__1, &a[k + (j + 2) * a_dim1], + lda); + i__1 = *m - j - 1; + cscal_(&i__1, &alpha, &a[k + (j + 2) * a_dim1], lda); + } else { + i__1 = *m - j - 1; + claset_("Full", &c__1, &i__1, &c_b19, &c_b19, &a[k + (j + + 2) * a_dim1], lda); + } + } + } + ++j; + goto L10; +L20: + + ; + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T using the lower triangle of A */ +/* ..................................................... */ + +L30: + if (j > f2cmin(*m,*nb)) { + goto L40; + } + +/* K is the column to be factorized */ +/* when being called from CSYTRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:M, J) := A(J:M, J) - H(J:M, 1:(J-1)) * L(J, J1:(J-1))^T, */ +/* where H(J:M, J) has been initialized to be A(J:M, J) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + cgemv_("No transpose", &mj, &i__1, &c_b6, &h__[j + k1 * h_dim1], + ldh, &a[j + a_dim1], lda, &c_b8, &h__[j + j * h_dim1], & + c__1); + } + +/* Copy H(J:M, J) into WORK */ + + ccopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J:M, J-1) * T(J-1,J), */ +/* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) */ + + i__1 = j + (k - 1) * a_dim1; + q__1.r = -a[i__1].r, q__1.i = -a[i__1].i; + alpha.r = q__1.r, alpha.i = q__1.i; + caxpy_(&mj, &alpha, &a[j + (k - 2) * a_dim1], &c__1, &work[1], & + c__1); + } + +/* Set A(J, J) = T(J, J) */ + + i__1 = j + k * a_dim1; + a[i__1].r = work[1].r, a[i__1].i = work[1].i; + + if (j < *m) { + +/* Compute WORK(2:M) = T(J, J) L((J+1):M, J) */ +/* where A(J, J) = T(J, J) and A((J+1):M, J-1) = L((J+1):M, J) */ + + if (k > 1) { + i__1 = j + k * a_dim1; + q__1.r = -a[i__1].r, q__1.i = -a[i__1].i; + alpha.r = q__1.r, alpha.i = q__1.i; + i__1 = *m - j; + caxpy_(&i__1, &alpha, &a[j + 1 + (k - 1) * a_dim1], &c__1, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:M)|) */ + + i__1 = *m - j; + i2 = icamax_(&i__1, &work[2], &c__1) + 1; + i__1 = i2; + piv.r = work[i__1].r, piv.i = work[i__1].i; + +/* Apply symmetric pivot */ + + if (i2 != 2 && (piv.r != 0.f || piv.i != 0.)) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + i__1 = i2; + i__2 = i1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + i__1 = i1; + work[i__1].r = piv.r, work[i__1].i = piv.i; + +/* Swap A(I1+1:M, I1) with A(I2, I1+1:M) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + cswap_(&i__1, &a[i1 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, &a[ + i2 + (*j1 + i1) * a_dim1], lda); + +/* Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + + if (i2 < *m) { + i__1 = *m - i2; + cswap_(&i__1, &a[i2 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, + &a[i2 + 1 + (*j1 + i2 - 1) * a_dim1], &c__1); + } + +/* Swap A(I1, I1) with A(I2, I2) */ + + i__1 = i1 + (*j1 + i1 - 1) * a_dim1; + piv.r = a[i__1].r, piv.i = a[i__1].i; + i__1 = i1 + (*j1 + i1 - 1) * a_dim1; + i__2 = i2 + (*j1 + i2 - 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = i2 + (*j1 + i2 - 1) * a_dim1; + a[i__1].r = piv.r, a[i__1].i = piv.i; + +/* Swap H(I1, I1:J1) with H(I2, I2:J1) */ + + i__1 = i1 - 1; + cswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + cswap_(&i__1, &a[i1 + a_dim1], lda, &a[i2 + a_dim1], lda); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J+1, J) = T(J+1, J) */ + + i__1 = j + 1 + k * a_dim1; + a[i__1].r = work[2].r, a[i__1].i = work[2].i; + + if (j < *nb) { + +/* Copy A(J+1:M, J+1) into H(J+1:M, J), */ + + i__1 = *m - j; + ccopy_(&i__1, &a[j + 1 + (k + 1) * a_dim1], &c__1, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1) */ + + if (j < *m - 1) { + i__1 = j + 1 + k * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + c_div(&q__1, &c_b8, &a[j + 1 + k * a_dim1]); + alpha.r = q__1.r, alpha.i = q__1.i; + i__1 = *m - j - 1; + ccopy_(&i__1, &work[3], &c__1, &a[j + 2 + k * a_dim1], & + c__1); + i__1 = *m - j - 1; + cscal_(&i__1, &alpha, &a[j + 2 + k * a_dim1], &c__1); + } else { + i__1 = *m - j - 1; + claset_("Full", &i__1, &c__1, &c_b19, &c_b19, &a[j + 2 + + k * a_dim1], lda); + } + } + } + ++j; + goto L30; +L40: + ; + } + return 0; + +/* End of CLASYF_AA */ + +} /* clasyf_aa__ */ + diff --git a/lapack-netlib/SRC/clasyf_rk.c b/lapack-netlib/SRC/clasyf_rk.c new file mode 100644 index 000000000..d3b204ee2 --- /dev/null +++ b/lapack-netlib/SRC/clasyf_rk.c @@ -0,0 +1,1594 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bound +ed Bunch-Kaufman (rook) diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLASYF_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E( * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CLASYF_RK computes a partial factorization of a complex symmetric */ +/* > matrix A using the bounded Bunch-Kaufman (rook) diagonal */ +/* > pivoting method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > CLASYF_RK is an auxiliary routine called by CSYTRF_RK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. */ +/* > If UPLO = 'U': the leading N-by-N upper triangular part */ +/* > of A contains the upper triangular part of the matrix A, */ +/* > and the strictly lower triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > If UPLO = 'L': the leading N-by-N lower triangular part */ +/* > of A contains the lower triangular part of the matrix A, */ +/* > and the strictly upper triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > On exit, contains: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N) */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > IPIV describes the permutation matrix P in the factorization */ +/* > of matrix A as follows. The absolute value of IPIV(k) */ +/* > represents the index of row and column that were */ +/* > interchanged with the k-th row and column. The value of UPLO */ +/* > describes the order in which the interchanges were applied. */ +/* > Also, the sign of IPIV represents the block structure of */ +/* > the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 */ +/* > diagonal blocks which correspond to 1 or 2 interchanges */ +/* > at each factorization step. */ +/* > */ +/* > If UPLO = 'U', */ +/* > ( in factorization order, k decreases from N to 1 ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the submatrix A(1:N,N-KB+1:N); */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k-1) < 0 means: */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,N-KB+1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k-1) != k-1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the submatrix A(1:N,N-KB+1:N). */ +/* > If -IPIV(k-1) = k-1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > */ +/* > If UPLO = 'L', */ +/* > ( in factorization order, k increases from 1 to N ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the submatrix A(1:N,1:KB). */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k+1) < 0 means: */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the submatrix A(1:N,1:KB). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k+1) != k+1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the submatrix A(1:N,1:KB). */ +/* > If -IPIV(k+1) = k+1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > < 0: If INFO = -k, the k-th argument had an illegal value */ +/* > */ +/* > > 0: If INFO = k, the matrix A is singular, because: */ +/* > If UPLO = 'U': column k in the upper */ +/* > triangular part of A contains all zeros. */ +/* > If UPLO = 'L': column k in the lower */ +/* > triangular part of A contains all zeros. */ +/* > */ +/* > Therefore D(k,k) is exactly zero, and superdiagonal */ +/* > elements of column k of U (or subdiagonal elements of */ +/* > column k of L ) are all zeros. The factorization has */ +/* > been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if */ +/* > it is used to solve a system of equations. */ +/* > */ +/* > NOTE: INFO only stores the first occurrence of */ +/* > a singularity, any subsequent occurrence of singularity */ +/* > is not stored in INFO even though the factorization */ +/* > always completes. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > December 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int clasyf_rk_(char *uplo, integer *n, integer *nb, integer + *kb, complex *a, integer *lda, complex *e, integer *ipiv, complex *w, + integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + complex t; + real alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), cgemm_(char *, char *, integer *, integer *, integer * + , complex *, complex *, integer *, complex *, integer *, complex * + , complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + real sfmin; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + integer itemp; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer kstep; + real stemp; + complex r1, d11, d12, d21, d22; + integer jb, ii, jj, kk, kp; + real absakk; + integer kw; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + real colmax, rowmax; + integer kkw; + + +/* -- 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; + --e; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + +/* Compute machine safe minimum */ + + sfmin = slamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* Initialize the first entry of array E, where superdiagonal */ +/* elements of D are stored */ + + e[1].r = 0.f, e[1].i = 0.f; + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[k + kw * + w_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + kw * w_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + +/* Set E( K ) to zero */ + + if (k > 1) { + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(r__2)); + } else { + rowmax = 0.f; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + stemp = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (kw - 1) * w_dim1; + if (! ((r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + (kw - 1) * w_dim1]), abs(r__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* ============================================================ */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = k - p; + ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + ccopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + +/* Interchange rows K and P in last N-K+1 columns of A */ +/* and last N-K+2 columns of W */ + + i__1 = *n - k + 1; + cswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + cswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Updated column KP is already stored in column KKW of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = k - 1 - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + ccopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + +/* Interchange rows KK and KP in last N-KK+1 columns */ +/* of A and W */ + + i__1 = *n - kk + 1; + cswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column KW of W now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Store U(k) in column k of A */ + + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), abs(r__2)) >= sfmin) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = k - 1; + cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L14: */ + } + } + } + +/* Store the superdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ +/* hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + + if (k > 2) { + +/* Store U(k) and U(k-1) in columns k and k-1 of A */ + + i__1 = k - 1 + kw * w_dim1; + d12.r = w[i__1].r, d12.i = w[i__1].i; + c_div(&q__1, &w[k + kw * w_dim1], &d12); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d12); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L20: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy superdiagonal element of D(K) to E(K) and */ +/* ZERO out superdiagonal entry of A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k; + i__2 = k - 1 + kw * w_dim1; + e[i__1].r = w[i__2].r, e[i__1].i = w[i__2].i; + i__1 = k - 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* Initialize the unused last entry of the subdiagonal array E. */ + + i__1 = *n; + e[i__1].r = 0.f, e[i__1].i = 0.f; + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[k + k * + w_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + k * w_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + +/* Set E( K ) to zero */ + + if (k < *n) { + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(& + w[jmax + (k + 1) * w_dim1]), abs(r__2)); + } else { + rowmax = 0.f; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + stemp = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (k + 1) * w_dim1; + if (! ((r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + (k + 1) * w_dim1]), abs(r__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* ============================================================ */ + + kk = k + kstep - 1; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = p - k; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + ccopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + +/* Interchange rows K and P in first K columns of A */ +/* and first K+1 columns of W */ + + cswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + cswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Updated column KP is already stored in column KK of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - k - 1; + ccopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + ccopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + +/* Interchange rows KK and KP in first KK columns of A and W */ + + cswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + +/* Store L(k) in column k of A */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), abs(r__2)) >= sfmin) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = *n - k; + cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L74: */ + } + } + } + +/* Store the subdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Store L(k) and L(k+1) in columns k and k+1 of A */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k + k * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L80: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy subdiagonal element of D(K) to E(K) and */ +/* ZERO out subdiagonal entry of A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k; + i__2 = k + 1 + k * w_dim1; + e[i__1].r = w[i__2].r, e[i__1].i = w[i__2].i; + i__1 = k + 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + + return 0; + +/* End of CLASYF_RK */ + +} /* clasyf_rk__ */ + diff --git a/lapack-netlib/SRC/clasyf_rook.c b/lapack-netlib/SRC/clasyf_rook.c new file mode 100644 index 000000000..9e482fc70 --- /dev/null +++ b/lapack-netlib/SRC/clasyf_rook.c @@ -0,0 +1,1520 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bu +nch-Kaufman ("rook") diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLASYF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLASYF_ROOK computes a partial factorization of a complex symmetric */ +/* > matrix A using the bounded Bunch-Kaufman ("rook") diagonal */ +/* > pivoting method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > CLASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, A contains details of the partial factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int clasyf_rook_(char *uplo, integer *n, integer *nb, + integer *kb, complex *a, integer *lda, integer *ipiv, complex *w, + integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + complex t; + real alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), cgemm_(char *, char *, integer *, integer *, integer * + , complex *, complex *, integer *, complex *, integer *, complex * + , complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + real sfmin; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + integer itemp; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer kstep; + real stemp; + complex r1, d11, d12, d21, d22; + integer jb, ii, jj, kk, kp; + real absakk; + integer kw; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + real colmax; + integer jp1, jp2; + real rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + +/* Compute machine safe minimum */ + + sfmin = slamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[k + kw * + w_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + kw * w_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(r__2)); + } else { + rowmax = 0.f; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + stemp = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (kw - 1) * w_dim1; + if (! ((r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + (kw - 1) * w_dim1]), abs(r__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* ============================================================ */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = k - p; + ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + ccopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + +/* Interchange rows K and P in last N-K+1 columns of A */ +/* and last N-K+2 columns of W */ + + i__1 = *n - k + 1; + cswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + cswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Updated column KP is already stored in column KKW of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = k - 1 - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + ccopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + +/* Interchange rows KK and KP in last N-KK+1 columns */ +/* of A and W */ + + i__1 = *n - kk + 1; + cswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column KW of W now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Store U(k) in column k of A */ + + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), abs(r__2)) >= sfmin) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = k - 1; + cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L14: */ + } + } + } + } + + } else { + +/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ +/* hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + + if (k > 2) { + +/* Store U(k) and U(k-1) in columns k and k-1 of A */ + + i__1 = k - 1 + kw * w_dim1; + d12.r = w[i__1].r, d12.i = w[i__1].i; + c_div(&q__1, &w[k + kw * w_dim1], &d12); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d12); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L20: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n */ + + j = k + 1; +L60: + + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + jj = j - 1; + if (jp1 != jj && kstep == 2) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j <= *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[k + k * + w_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + k * w_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(& + w[jmax + (k + 1) * w_dim1]), abs(r__2)); + } else { + rowmax = 0.f; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + stemp = (r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (k + 1) * w_dim1; + if (! ((r__1 = w[i__1].r, abs(r__1)) + (r__2 = r_imag(&w[imax + + (k + 1) * w_dim1]), abs(r__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* ============================================================ */ + + kk = k + kstep - 1; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = p - k; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + ccopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + +/* Interchange rows K and P in first K columns of A */ +/* and first K+1 columns of W */ + + cswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + cswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Updated column KP is already stored in column KK of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - k - 1; + ccopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + ccopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + +/* Interchange rows KK and KP in first KK columns of A and W */ + + cswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + +/* Store L(k) in column k of A */ + + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), abs(r__2)) >= sfmin) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = *n - k; + cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L74: */ + } + } + } + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Store L(k) and L(k+1) in columns k and k+1 of A */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k + k * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L80: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* in columns 1:k-1 */ + + j = k - 1; +L120: + + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + + --j; + if (jp2 != jj && j >= 1) { + cswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + jj = j + 1; + if (jp1 != jj && kstep == 2) { + cswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of CLASYF_ROOK */ + +} /* clasyf_rook__ */ + diff --git a/lapack-netlib/SRC/clatbs.c b/lapack-netlib/SRC/clatbs.c new file mode 100644 index 000000000..25f3ceb83 --- /dev/null +++ b/lapack-netlib/SRC/clatbs.c @@ -0,0 +1,1633 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATBS solves a triangular banded system of equations. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLATBS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, */ +/* SCALE, CNORM, INFO ) */ + +/* CHARACTER DIAG, NORMIN, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* REAL SCALE */ +/* REAL CNORM( * ) */ +/* COMPLEX AB( LDAB, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATBS solves one of the triangular systems */ +/* > */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */ +/* > */ +/* > with scaling to prevent overflow, where A is an upper or lower */ +/* > triangular band matrix. Here A**T denotes the transpose of A, x and b */ +/* > are n-element vectors, and s is a scaling factor, usually less than */ +/* > or equal to 1, chosen so that the components of x will be less than */ +/* > the overflow threshold. If the unscaled problem will not cause */ +/* > overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A */ +/* > is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ +/* > non-trivial solution to A*x = 0 is returned. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': Solve A * x = s*b (No transpose) */ +/* > = 'T': Solve A**T * x = s*b (Transpose) */ +/* > = 'C': Solve A**H * x = s*b (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NORMIN */ +/* > \verbatim */ +/* > NORMIN is CHARACTER*1 */ +/* > Specifies whether CNORM has been set or not. */ +/* > = 'Y': CNORM contains the column norms on entry */ +/* > = 'N': CNORM is not set on entry. On exit, the norms will */ +/* > be computed and stored in CNORM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of subdiagonals or superdiagonals in the */ +/* > triangular matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first KD+1 rows of the array. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (N) */ +/* > On entry, the right hand side b of the triangular system. */ +/* > On exit, X is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scaling factor s for the triangular system */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */ +/* > If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* > the vector x is an exact or approximate solution to A*x = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CNORM */ +/* > \verbatim */ +/* > CNORM is REAL array, dimension (N) */ +/* > */ +/* > If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* > contains the norm of the off-diagonal part of the j-th column */ +/* > of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* > to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* > must be greater than or equal to the 1-norm. */ +/* > */ +/* > If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* > returns the 1-norm of the offdiagonal part of the j-th column */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A rough bound on x is computed; if that is less than overflow, CTBSV */ +/* > is called, otherwise, specific code is used which checks for possible */ +/* > overflow or divide-by-zero at every operation. */ +/* > */ +/* > A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* > if A is lower triangular is */ +/* > */ +/* > x[1:n] := b[1:n] */ +/* > for j = 1, ..., n */ +/* > x(j) := x(j) / A(j,j) */ +/* > x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* > end */ +/* > */ +/* > Define bounds on the components of x after j iterations of the loop: */ +/* > M(j) = bound on x[1:j] */ +/* > G(j) = bound on x[j+1:n] */ +/* > Initially, let M(0) = 0 and G(0) = f2cmax{x(i), i=1,...,n}. */ +/* > */ +/* > Then for iteration j+1 we have */ +/* > M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* > G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* > <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ +/* > */ +/* > where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* > column j+1 of A, not counting the diagonal. Hence */ +/* > */ +/* > G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* > 1<=i<=j */ +/* > and */ +/* > */ +/* > |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* > 1<=i< j */ +/* > */ +/* > Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the */ +/* > reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* > f2cmax(underflow, 1/overflow). */ +/* > */ +/* > The bound on x(j) is also used to determine when a step in the */ +/* > columnwise method can be performed without fear of overflow. If */ +/* > the computed bound is greater than a large constant, x is scaled to */ +/* > prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* > 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ +/* > */ +/* > Similarly, a row-wise scheme is used to solve A**T *x = b or */ +/* > A**H *x = b. The basic algorithm for A upper triangular is */ +/* > */ +/* > for j = 1, ..., n */ +/* > x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ +/* > end */ +/* > */ +/* > We simultaneously compute two bounds */ +/* > G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ +/* > M(j) = bound on x(i), 1<=i<=j */ +/* > */ +/* > The initial values are G(0) = 0, M(0) = f2cmax{b(i), i=1,..,n}, and we */ +/* > add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* > Then the bound on x(j) is */ +/* > */ +/* > M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ +/* > */ +/* > <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* > 1<=i<=j */ +/* > */ +/* > and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater */ +/* > than f2cmax(underflow, 1/overflow). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int clatbs_(char *uplo, char *trans, char *diag, char * + normin, integer *n, integer *kd, complex *ab, integer *ldab, complex * + x, real *scale, real *cnorm, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer jinc, jlen; + real xbnd; + integer imax; + real tmax; + complex tjjs; + real xmax, grow; + integer i__, j, maind; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real tscal; + complex uscal; + integer jlast; + extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer + *, complex *, integer *); + complex csumj; + extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer * + , complex *, integer *); + logical upper; + extern /* Subroutine */ int slabad_(real *, real *); + real xj; + extern integer icamax_(integer *, complex *, integer *); + extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + extern real scasum_(integer *, complex *, integer *); + logical notran; + integer jfirst; + real smlnum; + logical nounit; + real rec, tjj; + + +/* -- 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; + --x; + --cnorm; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*kd < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATBS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + smlnum /= slamch_("Precision"); + bignum = 1.f / smlnum; + *scale = 1.f; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = j - 1; + jlen = f2cmin(i__2,i__3); + cnorm[j] = scasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], & + c__1); +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + jlen = f2cmin(i__2,i__3); + if (jlen > 0) { + cnorm[j] = scasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1); + } else { + cnorm[j] = 0.f; + } +/* L20: */ + } + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM/2. */ + + imax = isamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum * .5f) { + tscal = 1.f; + } else { + tscal = .5f / (smlnum * tmax); + sscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine CTBSV can be used. */ + + xmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j; + r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, abs(r__1)) + (r__2 = + r_imag(&x[j]) / 2.f, abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L30: */ + } + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = *kd + 1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L60; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + + i__3 = maind + j * ab_dim1; + tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i; + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + + if (tjj >= smlnum) { + +/* M(j) = G(j-1) / abs(A(j,j)) */ + +/* Computing MIN */ + r__1 = xbnd, r__2 = f2cmin(1.f,tjj) * grow; + xbnd = f2cmin(r__1,r__2); + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.f; + } + + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.f; + } +/* L40: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = .5f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1.f / (cnorm[j] + 1.f); +/* L50: */ + } + } +L60: + + ; + } else { + +/* Compute the growth in A**T * x = b or A**H * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = *kd + 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L90; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = f2cmax( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.f; +/* Computing MIN */ + r__1 = grow, r__2 = xbnd / xj; + grow = f2cmin(r__1,r__2); + + i__3 = maind + j * ab_dim1; + tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i; + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + + if (tjj >= smlnum) { + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + if (xj > tjj) { + xbnd *= tjj / xj; + } + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.f; + } +/* L70: */ + } + grow = f2cmin(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = .5f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.f; + grow /= xj; +/* L80: */ + } + } +L90: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + ctbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum * .5f) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum * .5f / xmax; + csscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } else { + xmax *= 2.f; + } + + if (notran) { + +/* Solve A * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + if (nounit) { + i__3 = maind + j * ab_dim1; + q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3].i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L105; + } + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.f) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L100: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + xj = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L105: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5f; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + csscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5f; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(f2cmax(1,j-kd):j-1) := x(f2cmax(1,j-kd):j-1) - */ +/* x(j)* A(f2cmax(1,j-kd):j-1,j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + i__3 = j; + q__2.r = -x[i__3].r, q__2.i = -x[i__3].i; + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + caxpy_(&jlen, &q__1, &ab[*kd + 1 - jlen + j * ab_dim1] + , &c__1, &x[j - jlen], &c__1); + i__3 = j - 1; + i__ = icamax_(&i__3, &x[1], &c__1); + i__3 = i__; + xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( + &x[i__]), abs(r__2)); + } + } else if (j < *n) { + +/* Compute the update */ +/* x(j+1:f2cmin(j+kd,n)) := x(j+1:f2cmin(j+kd,n)) - */ +/* x(j) * A(j+1:f2cmin(j+kd,n),j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 0) { + i__3 = j; + q__2.r = -x[i__3].r, q__2.i = -x[i__3].i; + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + caxpy_(&jlen, &q__1, &ab[j * ab_dim1 + 2], &c__1, &x[ + j + 1], &c__1); + } + i__3 = *n - j; + i__ = j + icamax_(&i__3, &x[j + 1], &c__1); + i__3 = i__; + xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[ + i__]), abs(r__2)); + } +/* L110: */ + } + + } else if (lsame_(trans, "T")) { + +/* Solve A**T * x = b */ + + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + uscal.r = tscal, uscal.i = 0.f; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + i__3 = maind + j * ab_dim1; + q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3] + .i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + cladiv_(&q__1, &uscal, &tjjs); + uscal.r = q__1.r, uscal.i = q__1.i; + } + if (rec < 1.f) { + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0.f, csumj.i = 0.f; + if (uscal.r == 1.f && uscal.i == 0.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call CDOTU to perform the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + cdotu_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1] + , &c__1, &x[j - jlen], &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 1) { + cdotu_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1, + &x[j + 1], &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = *kd + i__ - jlen + j * ab_dim1; + q__3.r = ab[i__4].r * uscal.r - ab[i__4].i * + uscal.i, q__3.i = ab[i__4].r * uscal.i + + ab[i__4].i * uscal.r; + i__5 = j - jlen - 1 + i__; + q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, + q__2.i = q__3.r * x[i__5].i + q__3.i * x[ + i__5].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L120: */ + } + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + 1 + j * ab_dim1; + q__3.r = ab[i__4].r * uscal.r - ab[i__4].i * + uscal.i, q__3.i = ab[i__4].r * uscal.i + + ab[i__4].i * uscal.r; + i__5 = j + i__; + q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, + q__2.i = q__3.r * x[i__5].i + q__3.i * x[ + i__5].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L130: */ + } + } + } + + q__1.r = tscal, q__1.i = 0.f; + if (uscal.r == q__1.r && uscal.i == q__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - + csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + i__3 = maind + j * ab_dim1; + q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3] + .i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L145; + } + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**T *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L140: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + *scale = 0.f; + xmax = 0.f; + } +L145: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + cladiv_(&q__2, &x[j], &tjjs); + q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } +/* Computing MAX */ + i__3 = j; + r__3 = xmax, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[j]), abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L150: */ + } + + } else { + +/* Solve A**H * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + uscal.r = tscal, uscal.i = 0.f; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + r_cnjg(&q__2, &ab[maind + j * ab_dim1]); + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + cladiv_(&q__1, &uscal, &tjjs); + uscal.r = q__1.r, uscal.i = q__1.i; + } + if (rec < 1.f) { + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0.f, csumj.i = 0.f; + if (uscal.r == 1.f && uscal.i == 0.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call CDOTC to perform the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + cdotc_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1] + , &c__1, &x[j - jlen], &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 1) { + cdotc_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1, + &x[j + 1], &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + r_cnjg(&q__4, &ab[*kd + i__ - jlen + j * ab_dim1]) + ; + q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, + q__3.i = q__4.r * uscal.i + q__4.i * + uscal.r; + i__4 = j - jlen - 1 + i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L160: */ + } + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + r_cnjg(&q__4, &ab[i__ + 1 + j * ab_dim1]); + q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, + q__3.i = q__4.r * uscal.i + q__4.i * + uscal.r; + i__4 = j + i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L170: */ + } + } + } + + q__1.r = tscal, q__1.i = 0.f; + if (uscal.r == q__1.r && uscal.i == q__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - + csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + r_cnjg(&q__2, &ab[maind + j * ab_dim1]); + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L185; + } + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**H *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L180: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + *scale = 0.f; + xmax = 0.f; + } +L185: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + cladiv_(&q__2, &x[j], &tjjs); + q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } +/* Computing MAX */ + i__3 = j; + r__3 = xmax, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[j]), abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L190: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.f) { + r__1 = 1.f / tscal; + sscal_(n, &r__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of CLATBS */ + +} /* clatbs_ */ + diff --git a/lapack-netlib/SRC/clatdf.c b/lapack-netlib/SRC/clatdf.c new file mode 100644 index 000000000..44a186b69 --- /dev/null +++ b/lapack-netlib/SRC/clatdf.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 CLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contrib +ution to the reciprocal Dif-estimate. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLATDF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, */ +/* JPIV ) */ + +/* INTEGER IJOB, LDZ, N */ +/* REAL RDSCAL, RDSUM */ +/* INTEGER IPIV( * ), JPIV( * ) */ +/* COMPLEX RHS( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATDF computes the contribution to the reciprocal Dif-estimate */ +/* > by solving for x in Z * x = b, where b is chosen such that the norm */ +/* > of x is as large as possible. It is assumed that LU decomposition */ +/* > of Z has been computed by CGETC2. On entry RHS = f holds the */ +/* > contribution from earlier solved sub-systems, and on return RHS = x. */ +/* > */ +/* > The factorization of Z returned by CGETC2 has the form */ +/* > Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */ +/* > triangular with unit diagonal elements and U is upper triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > IJOB = 2: First compute an approximative null-vector e */ +/* > of Z using CGECON, e is normalized and solve for */ +/* > Zx = +-e - f with the sign giving the greater value of */ +/* > 2-norm(x). About 5 times as expensive as Default. */ +/* > IJOB .ne. 2: Local look ahead strategy where */ +/* > all entries of the r.h.s. b is chosen as either +1 or */ +/* > -1. Default. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ, N) */ +/* > On entry, the LU part of the factorization of the n-by-n */ +/* > matrix Z computed by CGETC2: Z = P * L * U * Q */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDA >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RHS */ +/* > \verbatim */ +/* > RHS is COMPLEX array, dimension (N). */ +/* > On entry, RHS contains contributions from other subsystems. */ +/* > On exit, RHS contains the solution of the subsystem with */ +/* > entries according to the value of IJOB (see above). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSUM */ +/* > \verbatim */ +/* > RDSUM is REAL */ +/* > On entry, the sum of squares of computed contributions to */ +/* > the Dif-estimate under computation by CTGSYL, where the */ +/* > scaling factor RDSCAL (see below) has been factored out. */ +/* > On exit, the corresponding sum of squares updated with the */ +/* > contributions from the current sub-system. */ +/* > If TRANS = 'T' RDSUM is not touched. */ +/* > NOTE: RDSUM only makes sense when CTGSY2 is called by CTGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSCAL */ +/* > \verbatim */ +/* > RDSCAL is REAL */ +/* > On entry, scaling factor used to prevent overflow in RDSUM. */ +/* > On exit, RDSCAL is updated w.r.t. the current contributions */ +/* > in RDSUM. */ +/* > If TRANS = 'T', RDSCAL is not touched. */ +/* > NOTE: RDSCAL only makes sense when CTGSY2 is called by */ +/* > CTGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N). */ +/* > The pivot indices; for 1 <= i <= N, row i of the */ +/* > matrix has been interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JPIV */ +/* > \verbatim */ +/* > JPIV is INTEGER array, dimension (N). */ +/* > The pivot indices; for 1 <= j <= N, column j of the */ +/* > matrix has been interchanged with column JPIV(j). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > This routine is a further developed implementation of algorithm */ +/* > BSOLVE in [1] using complete pivoting in the LU factorization. */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Bo Kagstrom and Lars Westin, */ +/* > Generalized Schur Methods with Condition Estimators for */ +/* > Solving the Generalized Sylvester Equation, IEEE Transactions */ +/* > on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */ +/* > */ +/* > [2] Peter Poromaa, */ +/* > On Efficient and Robust Estimators for the Separation */ +/* > between two Regular Matrix Pairs with Applications in */ +/* > Condition Estimation. Report UMINF-95.05, Department of */ +/* > Computing Science, Umea University, S-901 87 Umea, Sweden, */ +/* > 1995. */ + +/* ===================================================================== */ +/* Subroutine */ int clatdf_(integer *ijob, integer *n, complex *z__, integer + *ldz, complex *rhs, real *rdsum, real *rdscal, integer *ipiv, integer + *jpiv) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Local variables */ + integer info; + complex temp, work[8]; + integer i__, j, k; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + real scale; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + complex pmone; + extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + real rtemp, sminu, rwork[2], splus; + extern /* Subroutine */ int cgesc2_(integer *, complex *, integer *, + complex *, integer *, integer *, real *); + complex bm, bp; + extern /* Subroutine */ int cgecon_(char *, integer *, complex *, integer + *, real *, real *, complex *, real *, integer *); + complex xm[2], xp[2]; + extern /* Subroutine */ int classq_(integer *, complex *, integer *, real + *, real *), claswp_(integer *, complex *, integer *, integer *, + integer *, integer *, integer *); + extern real scasum_(integer *, complex *, 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..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --rhs; + --ipiv; + --jpiv; + + /* Function Body */ + if (*ijob != 2) { + +/* Apply permutations IPIV to RHS */ + + i__1 = *n - 1; + claswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1); + +/* Solve for L-part choosing RHS either to +1 or -1. */ + + q__1.r = -1.f, q__1.i = 0.f; + pmone.r = q__1.r, pmone.i = q__1.i; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = rhs[i__2].r + 1.f, q__1.i = rhs[i__2].i + 0.f; + bp.r = q__1.r, bp.i = q__1.i; + i__2 = j; + q__1.r = rhs[i__2].r - 1.f, q__1.i = rhs[i__2].i + 0.f; + bm.r = q__1.r, bm.i = q__1.i; + splus = 1.f; + +/* Lockahead for L- part RHS(1:N-1) = +-1 */ +/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */ + + i__2 = *n - j; + cdotc_(&q__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1 + + j * z_dim1], &c__1); + splus += q__1.r; + i__2 = *n - j; + cdotc_(&q__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); + sminu = q__1.r; + i__2 = j; + splus *= rhs[i__2].r; + if (splus > sminu) { + i__2 = j; + rhs[i__2].r = bp.r, rhs[i__2].i = bp.i; + } else if (sminu > splus) { + i__2 = j; + rhs[i__2].r = bm.r, rhs[i__2].i = bm.i; + } else { + +/* In this case the updating sums are equal and we can */ +/* choose RHS(J) +1 or -1. The first time this happens we */ +/* choose -1, thereafter +1. This is a simple way to get */ +/* good estimates of matrices like Byers well-known example */ +/* (see [1]). (Not done in BSOLVE.) */ + + i__2 = j; + i__3 = j; + q__1.r = rhs[i__3].r + pmone.r, q__1.i = rhs[i__3].i + + pmone.i; + rhs[i__2].r = q__1.r, rhs[i__2].i = q__1.i; + pmone.r = 1.f, pmone.i = 0.f; + } + +/* Compute the remaining r.h.s. */ + + i__2 = j; + q__1.r = -rhs[i__2].r, q__1.i = -rhs[i__2].i; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = *n - j; + caxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); +/* L10: */ + } + +/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */ +/* In BSOLVE and will hopefully give us a better estimate because */ +/* any ill-conditioning of the original matrix is transferred to U */ +/* and not to L. U(N, N) is an approximation to sigma_min(LU). */ + + i__1 = *n - 1; + ccopy_(&i__1, &rhs[1], &c__1, work, &c__1); + i__1 = *n - 1; + i__2 = *n; + q__1.r = rhs[i__2].r + 1.f, q__1.i = rhs[i__2].i + 0.f; + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = *n; + i__2 = *n; + q__1.r = rhs[i__2].r - 1.f, q__1.i = rhs[i__2].i + 0.f; + rhs[i__1].r = q__1.r, rhs[i__1].i = q__1.i; + splus = 0.f; + sminu = 0.f; + for (i__ = *n; i__ >= 1; --i__) { + c_div(&q__1, &c_b1, &z__[i__ + i__ * z_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + i__1 = i__ - 1; + i__2 = i__ - 1; + q__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, q__1.i = + work[i__2].r * temp.i + work[i__2].i * temp.r; + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = i__; + i__2 = i__; + q__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, q__1.i = + rhs[i__2].r * temp.i + rhs[i__2].i * temp.r; + rhs[i__1].r = q__1.r, rhs[i__1].i = q__1.i; + i__1 = *n; + for (k = i__ + 1; k <= i__1; ++k) { + i__2 = i__ - 1; + i__3 = i__ - 1; + i__4 = k - 1; + i__5 = i__ + k * z_dim1; + q__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, q__3.i = + z__[i__5].r * temp.i + z__[i__5].i * temp.r; + q__2.r = work[i__4].r * q__3.r - work[i__4].i * q__3.i, + q__2.i = work[i__4].r * q__3.i + work[i__4].i * + q__3.r; + q__1.r = work[i__3].r - q__2.r, q__1.i = work[i__3].i - + q__2.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = i__; + i__3 = i__; + i__4 = k; + i__5 = i__ + k * z_dim1; + q__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, q__3.i = + z__[i__5].r * temp.i + z__[i__5].i * temp.r; + q__2.r = rhs[i__4].r * q__3.r - rhs[i__4].i * q__3.i, q__2.i = + rhs[i__4].r * q__3.i + rhs[i__4].i * q__3.r; + q__1.r = rhs[i__3].r - q__2.r, q__1.i = rhs[i__3].i - q__2.i; + rhs[i__2].r = q__1.r, rhs[i__2].i = q__1.i; +/* L20: */ + } + splus += c_abs(&work[i__ - 1]); + sminu += c_abs(&rhs[i__]); +/* L30: */ + } + if (splus > sminu) { + ccopy_(n, work, &c__1, &rhs[1], &c__1); + } + +/* Apply the permutations JPIV to the computed solution (RHS) */ + + i__1 = *n - 1; + claswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1); + +/* Compute the sum of squares */ + + classq_(n, &rhs[1], &c__1, rdscal, rdsum); + return 0; + } + +/* ENTRY IJOB = 2 */ + +/* Compute approximate nullvector XM of Z */ + + cgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info); + ccopy_(n, &work[*n], &c__1, xm, &c__1); + +/* Compute RHS */ + + i__1 = *n - 1; + claswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1); + cdotc_(&q__3, n, xm, &c__1, xm, &c__1); + c_sqrt(&q__2, &q__3); + c_div(&q__1, &c_b1, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + cscal_(n, &temp, xm, &c__1); + ccopy_(n, xm, &c__1, xp, &c__1); + caxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1); + q__1.r = -1.f, q__1.i = 0.f; + caxpy_(n, &q__1, xm, &c__1, &rhs[1], &c__1); + cgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale); + cgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale); + if (scasum_(n, xp, &c__1) > scasum_(n, &rhs[1], &c__1)) { + ccopy_(n, xp, &c__1, &rhs[1], &c__1); + } + +/* Compute the sum of squares */ + + classq_(n, &rhs[1], &c__1, rdscal, rdsum); + return 0; + +/* End of CLATDF */ + +} /* clatdf_ */ + diff --git a/lapack-netlib/SRC/clatps.c b/lapack-netlib/SRC/clatps.c new file mode 100644 index 000000000..2ee69f6f9 --- /dev/null +++ b/lapack-netlib/SRC/clatps.c @@ -0,0 +1,1597 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATPS solves a triangular system of equations with the matrix held in packed storage. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLATPS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, */ +/* CNORM, INFO ) */ + +/* CHARACTER DIAG, NORMIN, TRANS, UPLO */ +/* INTEGER INFO, N */ +/* REAL SCALE */ +/* REAL CNORM( * ) */ +/* COMPLEX AP( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATPS solves one of the triangular systems */ +/* > */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */ +/* > */ +/* > with scaling to prevent overflow, where A is an upper or lower */ +/* > triangular matrix stored in packed form. Here A**T denotes the */ +/* > transpose of A, A**H denotes the conjugate transpose of A, x and b */ +/* > are n-element vectors, and s is a scaling factor, usually less than */ +/* > or equal to 1, chosen so that the components of x will be less than */ +/* > the overflow threshold. If the unscaled problem will not cause */ +/* > overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A */ +/* > is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ +/* > non-trivial solution to A*x = 0 is returned. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': Solve A * x = s*b (No transpose) */ +/* > = 'T': Solve A**T * x = s*b (Transpose) */ +/* > = 'C': Solve A**H * x = s*b (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NORMIN */ +/* > \verbatim */ +/* > NORMIN is CHARACTER*1 */ +/* > Specifies whether CNORM has been set or not. */ +/* > = 'Y': CNORM contains the column norms on entry */ +/* > = 'N': CNORM is not set on entry. On exit, the norms will */ +/* > be computed and stored in CNORM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangular matrix A, packed columnwise in */ +/* > a linear array. The j-th column of A is stored in the array */ +/* > AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (N) */ +/* > On entry, the right hand side b of the triangular system. */ +/* > On exit, X is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scaling factor s for the triangular system */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */ +/* > If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* > the vector x is an exact or approximate solution to A*x = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CNORM */ +/* > \verbatim */ +/* > CNORM is REAL array, dimension (N) */ +/* > */ +/* > If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* > contains the norm of the off-diagonal part of the j-th column */ +/* > of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* > to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* > must be greater than or equal to the 1-norm. */ +/* > */ +/* > If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* > returns the 1-norm of the offdiagonal part of the j-th column */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A rough bound on x is computed; if that is less than overflow, CTPSV */ +/* > is called, otherwise, specific code is used which checks for possible */ +/* > overflow or divide-by-zero at every operation. */ +/* > */ +/* > A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* > if A is lower triangular is */ +/* > */ +/* > x[1:n] := b[1:n] */ +/* > for j = 1, ..., n */ +/* > x(j) := x(j) / A(j,j) */ +/* > x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* > end */ +/* > */ +/* > Define bounds on the components of x after j iterations of the loop: */ +/* > M(j) = bound on x[1:j] */ +/* > G(j) = bound on x[j+1:n] */ +/* > Initially, let M(0) = 0 and G(0) = f2cmax{x(i), i=1,...,n}. */ +/* > */ +/* > Then for iteration j+1 we have */ +/* > M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* > G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* > <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ +/* > */ +/* > where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* > column j+1 of A, not counting the diagonal. Hence */ +/* > */ +/* > G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* > 1<=i<=j */ +/* > and */ +/* > */ +/* > |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* > 1<=i< j */ +/* > */ +/* > Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the */ +/* > reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* > f2cmax(underflow, 1/overflow). */ +/* > */ +/* > The bound on x(j) is also used to determine when a step in the */ +/* > columnwise method can be performed without fear of overflow. If */ +/* > the computed bound is greater than a large constant, x is scaled to */ +/* > prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* > 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ +/* > */ +/* > Similarly, a row-wise scheme is used to solve A**T *x = b or */ +/* > A**H *x = b. The basic algorithm for A upper triangular is */ +/* > */ +/* > for j = 1, ..., n */ +/* > x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ +/* > end */ +/* > */ +/* > We simultaneously compute two bounds */ +/* > G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ +/* > M(j) = bound on x(i), 1<=i<=j */ +/* > */ +/* > The initial values are G(0) = 0, M(0) = f2cmax{b(i), i=1,..,n}, and we */ +/* > add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* > Then the bound on x(j) is */ +/* > */ +/* > M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ +/* > */ +/* > <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* > 1<=i<=j */ +/* > */ +/* > and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater */ +/* > than f2cmax(underflow, 1/overflow). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char * + normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer jinc, jlen; + real xbnd; + integer imax; + real tmax; + complex tjjs; + real xmax, grow; + integer i__, j; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real tscal; + complex uscal; + integer jlast; + extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer + *, complex *, integer *); + complex csumj; + extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + logical upper; + extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, + complex *, complex *, integer *), slabad_( + real *, real *); + integer ip; + real xj; + extern integer icamax_(integer *, complex *, integer *); + extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + extern real scasum_(integer *, complex *, integer *); + logical notran; + integer jfirst; + real smlnum; + logical nounit; + real rec, tjj; + + +/* -- 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 */ + --cnorm; + --x; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATPS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + smlnum /= slamch_("Precision"); + bignum = 1.f / smlnum; + *scale = 1.f; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + ip = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = scasum_(&i__2, &ap[ip], &c__1); + ip += j; +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + ip = 1; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1); + ip = ip + *n - j + 1; +/* L20: */ + } + cnorm[*n] = 0.f; + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM/2. */ + + imax = isamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum * .5f) { + tscal = 1.f; + } else { + tscal = .5f / (smlnum * tmax); + sscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine CTPSV can be used. */ + + xmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j; + r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, abs(r__1)) + (r__2 = + r_imag(&x[j]) / 2.f, abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L30: */ + } + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L60; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5f / f2cmax(xbnd,smlnum); + xbnd = grow; + ip = jfirst * (jfirst + 1) / 2; + jlen = *n; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + + i__3 = ip; + tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i; + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + + if (tjj >= smlnum) { + +/* M(j) = G(j-1) / abs(A(j,j)) */ + +/* Computing MIN */ + r__1 = xbnd, r__2 = f2cmin(1.f,tjj) * grow; + xbnd = f2cmin(r__1,r__2); + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.f; + } + + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.f; + } + ip += jinc * jlen; + --jlen; +/* L40: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = .5f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1.f / (cnorm[j] + 1.f); +/* L50: */ + } + } +L60: + + ; + } else { + +/* Compute the growth in A**T * x = b or A**H * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L90; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5f / f2cmax(xbnd,smlnum); + xbnd = grow; + ip = jfirst * (jfirst + 1) / 2; + jlen = 1; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = f2cmax( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.f; +/* Computing MIN */ + r__1 = grow, r__2 = xbnd / xj; + grow = f2cmin(r__1,r__2); + + i__3 = ip; + tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i; + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + + if (tjj >= smlnum) { + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + if (xj > tjj) { + xbnd *= tjj / xj; + } + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.f; + } + ++jlen; + ip += jinc * jlen; +/* L70: */ + } + grow = f2cmin(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = .5f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.f; + grow /= xj; +/* L80: */ + } + } +L90: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum * .5f) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum * .5f / xmax; + csscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } else { + xmax *= 2.f; + } + + if (notran) { + +/* Solve A * x = b */ + + ip = jfirst * (jfirst + 1) / 2; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + if (nounit) { + i__3 = ip; + q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3].i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L105; + } + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.f) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L100: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + xj = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L105: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5f; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + csscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5f; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ + + i__3 = j - 1; + i__4 = j; + q__2.r = -x[i__4].r, q__2.i = -x[i__4].i; + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], & + c__1); + i__3 = j - 1; + i__ = icamax_(&i__3, &x[1], &c__1); + i__3 = i__; + xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( + &x[i__]), abs(r__2)); + } + ip -= j; + } else { + if (j < *n) { + +/* Compute the update */ +/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ + + i__3 = *n - j; + i__4 = j; + q__2.r = -x[i__4].r, q__2.i = -x[i__4].i; + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], & + c__1); + i__3 = *n - j; + i__ = j + icamax_(&i__3, &x[j + 1], &c__1); + i__3 = i__; + xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( + &x[i__]), abs(r__2)); + } + ip = ip + *n - j + 1; + } +/* L110: */ + } + + } else if (lsame_(trans, "T")) { + +/* Solve A**T * x = b */ + + ip = jfirst * (jfirst + 1) / 2; + jlen = 1; + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + uscal.r = tscal, uscal.i = 0.f; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + i__3 = ip; + q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3] + .i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + cladiv_(&q__1, &uscal, &tjjs); + uscal.r = q__1.r, uscal.i = q__1.i; + } + if (rec < 1.f) { + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0.f, csumj.i = 0.f; + if (uscal.r == 1.f && uscal.i == 0.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call CDOTU to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + cdotu_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & + c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } else if (j < *n) { + i__3 = *n - j; + cdotu_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & + c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ip - j + i__; + q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * + uscal.i, q__3.i = ap[i__4].r * uscal.i + + ap[i__4].i * uscal.r; + i__5 = i__; + q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, + q__2.i = q__3.r * x[i__5].i + q__3.i * x[ + i__5].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L120: */ + } + } else if (j < *n) { + i__3 = *n - j; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ip + i__; + q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * + uscal.i, q__3.i = ap[i__4].r * uscal.i + + ap[i__4].i * uscal.r; + i__5 = j + i__; + q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, + q__2.i = q__3.r * x[i__5].i + q__3.i * x[ + i__5].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L130: */ + } + } + } + + q__1.r = tscal, q__1.i = 0.f; + if (uscal.r == q__1.r && uscal.i == q__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - + csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + i__3 = ip; + q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3] + .i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L145; + } + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**T *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L140: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + *scale = 0.f; + xmax = 0.f; + } +L145: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + cladiv_(&q__2, &x[j], &tjjs); + q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } +/* Computing MAX */ + i__3 = j; + r__3 = xmax, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[j]), abs(r__2)); + xmax = f2cmax(r__3,r__4); + ++jlen; + ip += jinc * jlen; +/* L150: */ + } + + } else { + +/* Solve A**H * x = b */ + + ip = jfirst * (jfirst + 1) / 2; + jlen = 1; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + uscal.r = tscal, uscal.i = 0.f; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + r_cnjg(&q__2, &ap[ip]); + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + cladiv_(&q__1, &uscal, &tjjs); + uscal.r = q__1.r, uscal.i = q__1.i; + } + if (rec < 1.f) { + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0.f, csumj.i = 0.f; + if (uscal.r == 1.f && uscal.i == 0.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call CDOTC to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + cdotc_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & + c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } else if (j < *n) { + i__3 = *n - j; + cdotc_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & + c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + r_cnjg(&q__4, &ap[ip - j + i__]); + q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, + q__3.i = q__4.r * uscal.i + q__4.i * + uscal.r; + i__4 = i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L160: */ + } + } else if (j < *n) { + i__3 = *n - j; + for (i__ = 1; i__ <= i__3; ++i__) { + r_cnjg(&q__4, &ap[ip + i__]); + q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, + q__3.i = q__4.r * uscal.i + q__4.i * + uscal.r; + i__4 = j + i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L170: */ + } + } + } + + q__1.r = tscal, q__1.i = 0.f; + if (uscal.r == q__1.r && uscal.i == q__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - + csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + r_cnjg(&q__2, &ap[ip]); + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L185; + } + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**H *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L180: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + *scale = 0.f; + xmax = 0.f; + } +L185: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + cladiv_(&q__2, &x[j], &tjjs); + q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } +/* Computing MAX */ + i__3 = j; + r__3 = xmax, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[j]), abs(r__2)); + xmax = f2cmax(r__3,r__4); + ++jlen; + ip += jinc * jlen; +/* L190: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.f) { + r__1 = 1.f / tscal; + sscal_(n, &r__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of CLATPS */ + +} /* clatps_ */ + diff --git a/lapack-netlib/SRC/clatrd.c b/lapack-netlib/SRC/clatrd.c new file mode 100644 index 000000000..b70105374 --- /dev/null +++ b/lapack-netlib/SRC/clatrd.c @@ -0,0 +1,857 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiago +nal form by an unitary similarity transformation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLATRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, LDW, N, NB */ +/* REAL E( * ) */ +/* COMPLEX A( LDA, * ), TAU( * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATRD reduces NB rows and columns of a complex Hermitian matrix A to */ +/* > Hermitian tridiagonal form by a unitary similarity */ +/* > transformation Q**H * A * Q, and returns the matrices V and W which are */ +/* > needed to apply the transformation to the unreduced part of A. */ +/* > */ +/* > If UPLO = 'U', CLATRD reduces the last NB rows and columns of a */ +/* > matrix, of which the upper triangle is supplied; */ +/* > if UPLO = 'L', CLATRD reduces the first NB rows and columns of a */ +/* > matrix, of which the lower triangle is supplied. */ +/* > */ +/* > This is an auxiliary routine called by CHETRD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of rows and columns to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit: */ +/* > if UPLO = 'U', the last NB columns have been reduced to */ +/* > tridiagonal form, with the diagonal elements overwriting */ +/* > the diagonal elements of A; the elements above the diagonal */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of elementary reflectors; */ +/* > if UPLO = 'L', the first NB columns have been reduced to */ +/* > tridiagonal form, with the diagonal elements overwriting */ +/* > the diagonal elements of A; the elements below the diagonal */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of elementary reflectors. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */ +/* > elements of the last NB columns of the reduced matrix; */ +/* > if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */ +/* > the first NB columns of the reduced matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (N-1) */ +/* > The scalar factors of the elementary reflectors, stored in */ +/* > TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX array, dimension (LDW,NB) */ +/* > The n-by-nb matrix W required to update the unreduced part */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= 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 complexOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(n) H(n-1) . . . H(n-nb+1). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex vector with */ +/* > v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */ +/* > and tau in TAU(i-1). */ +/* > */ +/* > If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(nb). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex vector with */ +/* > v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ +/* > and tau in TAU(i). */ +/* > */ +/* > The elements of the vectors v together form the n-by-nb matrix V */ +/* > which is needed, with W, to apply the transformation to the unreduced */ +/* > part of the matrix, using a Hermitian rank-2k update of the form: */ +/* > A := A - V*W**H - W*V**H. */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples */ +/* > with n = 5 and nb = 2: */ +/* > */ +/* > if UPLO = 'U': if UPLO = 'L': */ +/* > */ +/* > ( a a a v4 v5 ) ( d ) */ +/* > ( a a v4 v5 ) ( 1 d ) */ +/* > ( a 1 v5 ) ( v1 1 a ) */ +/* > ( d 1 ) ( v1 v2 a a ) */ +/* > ( d ) ( v1 v2 a a a ) */ +/* > */ +/* > where d denotes a diagonal element of the reduced matrix, a denotes */ +/* > an element of the original matrix that is unchanged, and vi denotes */ +/* > an element of the vector defining H(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int clatrd_(char *uplo, integer *n, integer *nb, complex *a, + integer *lda, real *e, complex *tau, complex *w, integer *ldw) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer i__; + complex alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), chemv_(char *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *), clarfg_(integer *, complex *, + complex *, integer *, complex *), clacgv_(integer *, complex *, + integer *); + integer iw; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --tau; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + + if (lsame_(uplo, "U")) { + +/* Reduce last NB columns of upper triangle */ + + i__1 = *n - *nb + 1; + for (i__ = *n; i__ >= i__1; --i__) { + iw = i__ - *n + *nb; + if (i__ < *n) { + +/* Update A(1:i,i) */ + + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + i__2 = *n - i__; + clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); + i__2 = *n - i__; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__, &i__2, &q__1, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & + c_b2, &a[i__ * a_dim1 + 1], &c__1); + i__2 = *n - i__; + clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); + i__2 = *n - i__; + clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = *n - i__; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__, &i__2, &q__1, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b2, &a[i__ * a_dim1 + 1], &c__1); + i__2 = *n - i__; + clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } + if (i__ > 1) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(1:i-2,i) */ + + i__2 = i__ - 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = i__ - 1; + clarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__ + - 1]); + i__2 = i__ - 1; + e[i__2] = alpha.r; + i__2 = i__ - 1 + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + +/* Compute W(1:i-1,i) */ + + i__2 = i__ - 1; + chemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ * + a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1); + if (i__ < *n) { + i__2 = i__ - 1; + i__3 = *n - i__; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw + + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], & + c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[( + i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], + &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &w[(iw + 1) * + w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1); + } + i__2 = i__ - 1; + cscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); + q__3.r = -.5f, q__3.i = 0.f; + i__2 = i__ - 1; + q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i = + q__3.r * tau[i__2].i + q__3.i * tau[i__2].r; + i__3 = i__ - 1; + cdotc_(&q__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ * + a_dim1 + 1], &c__1); + q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * + q__4.i + q__2.i * q__4.r; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = i__ - 1; + caxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * + w_dim1 + 1], &c__1); + } + +/* L10: */ + } + } else { + +/* Reduce first NB columns of lower triangle */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i:n,i) */ + + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + i__2 = i__ - 1; + clacgv_(&i__2, &w[i__ + w_dim1], ldw); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + a_dim1], lda, + &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], & + c__1); + i__2 = i__ - 1; + clacgv_(&i__2, &w[i__ + w_dim1], ldw); + i__2 = i__ - 1; + clacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + w_dim1], ldw, + &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], & + c__1); + i__2 = i__ - 1; + clacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + if (i__ < *n) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(i+2:n,i) */ + + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + clarfg_(&i__2, &alpha, &a[f2cmin(i__3,*n) + i__ * a_dim1], &c__1, + &tau[i__]); + i__2 = i__; + e[i__2] = alpha.r; + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + +/* Compute W(i+1:n,i) */ + + i__2 = *n - i__; + chemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1] + , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1 + + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, & + c_b1, &w[i__ * w_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 + + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & + c_b1, &w[i__ * w_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + 1 + + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + cscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); + q__3.r = -.5f, q__3.i = 0.f; + i__2 = i__; + q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i = + q__3.r * tau[i__2].i + q__3.i * tau[i__2].r; + i__3 = *n - i__; + cdotc_(&q__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[ + i__ + 1 + i__ * a_dim1], &c__1); + q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * + q__4.i + q__2.i * q__4.r; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = *n - i__; + caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + } + +/* L20: */ + } + } + + return 0; + +/* End of CLATRD */ + +} /* clatrd_ */ + diff --git a/lapack-netlib/SRC/clatrs.c b/lapack-netlib/SRC/clatrs.c new file mode 100644 index 000000000..972afe4d2 --- /dev/null +++ b/lapack-netlib/SRC/clatrs.c @@ -0,0 +1,1586 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATRS solves a triangular system of equations with the scale factor set to prevent overflow. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLATRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, */ +/* CNORM, INFO ) */ + +/* CHARACTER DIAG, NORMIN, TRANS, UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL SCALE */ +/* REAL CNORM( * ) */ +/* COMPLEX A( LDA, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATRS solves one of the triangular systems */ +/* > */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */ +/* > */ +/* > with scaling to prevent overflow. Here A is an upper or lower */ +/* > triangular matrix, A**T denotes the transpose of A, A**H denotes the */ +/* > conjugate transpose of A, x and b are n-element vectors, and s is a */ +/* > scaling factor, usually less than or equal to 1, chosen so that the */ +/* > components of x will be less than the overflow threshold. If the */ +/* > unscaled problem will not cause overflow, the Level 2 BLAS routine */ +/* > CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */ +/* > then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': Solve A * x = s*b (No transpose) */ +/* > = 'T': Solve A**T * x = s*b (Transpose) */ +/* > = 'C': Solve A**H * x = s*b (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NORMIN */ +/* > \verbatim */ +/* > NORMIN is CHARACTER*1 */ +/* > Specifies whether CNORM has been set or not. */ +/* > = 'Y': CNORM contains the column norms on entry */ +/* > = 'N': CNORM is not set on entry. On exit, the norms will */ +/* > be computed and stored in CNORM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The triangular matrix A. If UPLO = 'U', the leading n by n */ +/* > upper triangular part of the array A contains the upper */ +/* > triangular matrix, and the strictly lower triangular part of */ +/* > A is not referenced. If UPLO = 'L', the leading n by n lower */ +/* > triangular part of the array A contains the lower triangular */ +/* > matrix, and the strictly upper triangular part of A is not */ +/* > referenced. If DIAG = 'U', the diagonal elements of A are */ +/* > also not referenced and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax (1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (N) */ +/* > On entry, the right hand side b of the triangular system. */ +/* > On exit, X is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scaling factor s for the triangular system */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */ +/* > If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* > the vector x is an exact or approximate solution to A*x = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CNORM */ +/* > \verbatim */ +/* > CNORM is REAL array, dimension (N) */ +/* > */ +/* > If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* > contains the norm of the off-diagonal part of the j-th column */ +/* > of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* > to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* > must be greater than or equal to the 1-norm. */ +/* > */ +/* > If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* > returns the 1-norm of the offdiagonal part of the j-th column */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A rough bound on x is computed; if that is less than overflow, CTRSV */ +/* > is called, otherwise, specific code is used which checks for possible */ +/* > overflow or divide-by-zero at every operation. */ +/* > */ +/* > A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* > if A is lower triangular is */ +/* > */ +/* > x[1:n] := b[1:n] */ +/* > for j = 1, ..., n */ +/* > x(j) := x(j) / A(j,j) */ +/* > x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* > end */ +/* > */ +/* > Define bounds on the components of x after j iterations of the loop: */ +/* > M(j) = bound on x[1:j] */ +/* > G(j) = bound on x[j+1:n] */ +/* > Initially, let M(0) = 0 and G(0) = f2cmax{x(i), i=1,...,n}. */ +/* > */ +/* > Then for iteration j+1 we have */ +/* > M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* > G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* > <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ +/* > */ +/* > where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* > column j+1 of A, not counting the diagonal. Hence */ +/* > */ +/* > G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* > 1<=i<=j */ +/* > and */ +/* > */ +/* > |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* > 1<=i< j */ +/* > */ +/* > Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the */ +/* > reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* > f2cmax(underflow, 1/overflow). */ +/* > */ +/* > The bound on x(j) is also used to determine when a step in the */ +/* > columnwise method can be performed without fear of overflow. If */ +/* > the computed bound is greater than a large constant, x is scaled to */ +/* > prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* > 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ +/* > */ +/* > Similarly, a row-wise scheme is used to solve A**T *x = b or */ +/* > A**H *x = b. The basic algorithm for A upper triangular is */ +/* > */ +/* > for j = 1, ..., n */ +/* > x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ +/* > end */ +/* > */ +/* > We simultaneously compute two bounds */ +/* > G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ +/* > M(j) = bound on x(i), 1<=i<=j */ +/* > */ +/* > The initial values are G(0) = 0, M(0) = f2cmax{b(i), i=1,..,n}, and we */ +/* > add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* > Then the bound on x(j) is */ +/* > */ +/* > M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ +/* > */ +/* > <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* > 1<=i<=j */ +/* > */ +/* > and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater */ +/* > than f2cmax(underflow, 1/overflow). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char * + normin, integer *n, complex *a, integer *lda, complex *x, real *scale, + real *cnorm, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer jinc; + real xbnd; + integer imax; + real tmax; + complex tjjs; + real xmax, grow; + integer i__, j; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real tscal; + complex uscal; + integer jlast; + extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer + *, complex *, integer *); + complex csumj; + extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + logical upper; + extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *, + complex *, integer *, complex *, integer *), slabad_(real *, real *); + real xj; + extern integer icamax_(integer *, complex *, integer *); + extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + extern real scasum_(integer *, complex *, integer *); + logical notran; + integer jfirst; + real smlnum; + logical nounit; + real rec, tjj; + + +/* -- 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; + --x; + --cnorm; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + smlnum /= slamch_("Precision"); + bignum = 1.f / smlnum; + *scale = 1.f; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = scasum_(&i__2, &a[j * a_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = scasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); +/* L20: */ + } + cnorm[*n] = 0.f; + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM/2. */ + + imax = isamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum * .5f) { + tscal = 1.f; + } else { + tscal = .5f / (smlnum * tmax); + sscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine CTRSV can be used. */ + + xmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j; + r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, abs(r__1)) + (r__2 = + r_imag(&x[j]) / 2.f, abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L30: */ + } + xbnd = xmax; + + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L60; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + + i__3 = j + j * a_dim1; + tjjs.r = a[i__3].r, tjjs.i = a[i__3].i; + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + + if (tjj >= smlnum) { + +/* M(j) = G(j-1) / abs(A(j,j)) */ + +/* Computing MIN */ + r__1 = xbnd, r__2 = f2cmin(1.f,tjj) * grow; + xbnd = f2cmin(r__1,r__2); + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.f; + } + + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.f; + } +/* L40: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = .5f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1.f / (cnorm[j] + 1.f); +/* L50: */ + } + } +L60: + + ; + } else { + +/* Compute the growth in A**T * x = b or A**H * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L90; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = f2cmax( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.f; +/* Computing MIN */ + r__1 = grow, r__2 = xbnd / xj; + grow = f2cmin(r__1,r__2); + + i__3 = j + j * a_dim1; + tjjs.r = a[i__3].r, tjjs.i = a[i__3].i; + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + + if (tjj >= smlnum) { + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + if (xj > tjj) { + xbnd *= tjj / xj; + } + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.f; + } +/* L70: */ + } + grow = f2cmin(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = .5f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.f; + grow /= xj; +/* L80: */ + } + } +L90: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + ctrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum * .5f) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum * .5f / xmax; + csscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } else { + xmax *= 2.f; + } + + if (notran) { + +/* Solve A * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + if (nounit) { + i__3 = j + j * a_dim1; + q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L105; + } + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( + r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.f) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L100: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + xj = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L105: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5f; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + csscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5f; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ + + i__3 = j - 1; + i__4 = j; + q__2.r = -x[i__4].r, q__2.i = -x[i__4].i; + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + i__3 = j - 1; + i__ = icamax_(&i__3, &x[1], &c__1); + i__3 = i__; + xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( + &x[i__]), abs(r__2)); + } + } else { + if (j < *n) { + +/* Compute the update */ +/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ + + i__3 = *n - j; + i__4 = j; + q__2.r = -x[i__4].r, q__2.i = -x[i__4].i; + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, & + x[j + 1], &c__1); + i__3 = *n - j; + i__ = j + icamax_(&i__3, &x[j + 1], &c__1); + i__3 = i__; + xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( + &x[i__]), abs(r__2)); + } + } +/* L110: */ + } + + } else if (lsame_(trans, "T")) { + +/* Solve A**T * x = b */ + + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + uscal.r = tscal, uscal.i = 0.f; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + i__3 = j + j * a_dim1; + q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3] + .i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + cladiv_(&q__1, &uscal, &tjjs); + uscal.r = q__1.r, uscal.i = q__1.i; + } + if (rec < 1.f) { + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0.f, csumj.i = 0.f; + if (uscal.r == 1.f && uscal.i == 0.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call CDOTU to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } else if (j < *n) { + i__3 = *n - j; + cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, & + x[j + 1], &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * a_dim1; + q__3.r = a[i__4].r * uscal.r - a[i__4].i * + uscal.i, q__3.i = a[i__4].r * uscal.i + a[ + i__4].i * uscal.r; + i__5 = i__; + q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, + q__2.i = q__3.r * x[i__5].i + q__3.i * x[ + i__5].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L120: */ + } + } else if (j < *n) { + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * a_dim1; + q__3.r = a[i__4].r * uscal.r - a[i__4].i * + uscal.i, q__3.i = a[i__4].r * uscal.i + a[ + i__4].i * uscal.r; + i__5 = i__; + q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, + q__2.i = q__3.r * x[i__5].i + q__3.i * x[ + i__5].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L130: */ + } + } + } + + q__1.r = tscal, q__1.i = 0.f; + if (uscal.r == q__1.r && uscal.i == q__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - + csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + if (nounit) { + i__3 = j + j * a_dim1; + q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3] + .i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L145; + } + } + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**T *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L140: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + *scale = 0.f; + xmax = 0.f; + } +L145: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + cladiv_(&q__2, &x[j], &tjjs); + q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } +/* Computing MAX */ + i__3 = j; + r__3 = xmax, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[j]), abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L150: */ + } + + } else { + +/* Solve A**H * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), + abs(r__2)); + uscal.r = tscal, uscal.i = 0.f; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + } + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + cladiv_(&q__1, &uscal, &tjjs); + uscal.r = q__1.r, uscal.i = q__1.i; + } + if (rec < 1.f) { + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0.f, csumj.i = 0.f; + if (uscal.r == 1.f && uscal.i == 0.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call CDOTC to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } else if (j < *n) { + i__3 = *n - j; + cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, & + x[j + 1], &c__1); + csumj.r = q__1.r, csumj.i = q__1.i; + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + r_cnjg(&q__4, &a[i__ + j * a_dim1]); + q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, + q__3.i = q__4.r * uscal.i + q__4.i * + uscal.r; + i__4 = i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L160: */ + } + } else if (j < *n) { + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + r_cnjg(&q__4, &a[i__ + j * a_dim1]); + q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, + q__3.i = q__4.r * uscal.i + q__4.i * + uscal.r; + i__4 = i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + + q__2.i; + csumj.r = q__1.r, csumj.i = q__1.i; +/* L170: */ + } + } + } + + q__1.r = tscal, q__1.i = 0.f; + if (uscal.r == q__1.r && uscal.i == q__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - + csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + i__3 = j; + xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) + , abs(r__2)); + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; + tjjs.r = q__1.r, tjjs.i = q__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.f; + if (tscal == 1.f) { + goto L185; + } + } + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), + abs(r__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + csscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + cladiv_(&q__1, &x[j], &tjjs); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**H *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0.f, x[i__4].i = 0.f; +/* L180: */ + } + i__3 = j; + x[i__3].r = 1.f, x[i__3].i = 0.f; + *scale = 0.f; + xmax = 0.f; + } +L185: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + cladiv_(&q__2, &x[j], &tjjs); + q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } +/* Computing MAX */ + i__3 = j; + r__3 = xmax, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[j]), abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L190: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.f) { + r__1 = 1.f / tscal; + sscal_(n, &r__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of CLATRS */ + +} /* clatrs_ */ + diff --git a/lapack-netlib/SRC/clatrz.c b/lapack-netlib/SRC/clatrz.c new file mode 100644 index 000000000..831c4d3a6 --- /dev/null +++ b/lapack-netlib/SRC/clatrz.c @@ -0,0 +1,609 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATRZ factors an upper trapezoidal matrix by means of unitary transformations. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLATRZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK ) */ + +/* INTEGER L, LDA, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix */ +/* > [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means */ +/* > of unitary transformations, where Z is an (M+L)-by-(M+L) unitary */ +/* > matrix and, R and A1 are M-by-M upper triangular matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of columns of the matrix A containing the */ +/* > meaningful part of the Householder vectors. N-M >= L >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the leading M-by-N upper trapezoidal part of the */ +/* > array A must contain the matrix to be factorized. */ +/* > On exit, the leading M-by-M upper triangular part of A */ +/* > contains the upper triangular matrix R, and elements N-L+1 to */ +/* > N of the first M rows of A, with the array TAU, represent the */ +/* > unitary matrix Z as a product of M elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (M) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (M) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The factorization is obtained by Householder's method. The kth */ +/* > transformation matrix, Z( k ), which is used to introduce zeros into */ +/* > the ( m - k + 1 )th row of A, is given in the form */ +/* > */ +/* > Z( k ) = ( I 0 ), */ +/* > ( 0 T( k ) ) */ +/* > */ +/* > where */ +/* > */ +/* > T( k ) = I - tau*u( k )*u( k )**H, u( k ) = ( 1 ), */ +/* > ( 0 ) */ +/* > ( z( k ) ) */ +/* > */ +/* > tau is a scalar and z( k ) is an l element vector. tau and z( k ) */ +/* > are chosen to annihilate the elements of the kth row of A2. */ +/* > */ +/* > The scalar tau is returned in the kth element of TAU and the vector */ +/* > u( k ) in the kth row of A2, such that the elements of z( k ) are */ +/* > in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* > the upper triangular part of A1. */ +/* > */ +/* > Z is given by */ +/* > */ +/* > Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int clatrz_(integer *m, integer *n, integer *l, complex *a, + integer *lda, complex *tau, complex *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + complex q__1; + + /* Local variables */ + integer i__; + complex alpha; + extern /* Subroutine */ int clarz_(char *, integer *, integer *, integer * + , complex *, integer *, complex *, complex *, integer *, complex * + ), clarfg_(integer *, complex *, complex *, integer *, + complex *), clacgv_(integer *, complex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + if (*m == 0) { + return 0; + } else if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; +/* L10: */ + } + return 0; + } + + for (i__ = *m; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) to annihilate */ +/* [ A(i,i) A(i,n-l+1:n) ] */ + + clacgv_(l, &a[i__ + (*n - *l + 1) * a_dim1], lda); + r_cnjg(&q__1, &a[i__ + i__ * a_dim1]); + alpha.r = q__1.r, alpha.i = q__1.i; + i__1 = *l + 1; + clarfg_(&i__1, &alpha, &a[i__ + (*n - *l + 1) * a_dim1], lda, &tau[ + i__]); + i__1 = i__; + r_cnjg(&q__1, &tau[i__]); + tau[i__1].r = q__1.r, tau[i__1].i = q__1.i; + +/* Apply H(i) to A(1:i-1,i:n) from the right */ + + i__1 = i__ - 1; + i__2 = *n - i__ + 1; + r_cnjg(&q__1, &tau[i__]); + clarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1], + lda, &q__1, &a[i__ * a_dim1 + 1], lda, &work[1]); + i__1 = i__ + i__ * a_dim1; + r_cnjg(&q__1, &alpha); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* L20: */ + } + + return 0; + +/* End of CLATRZ */ + +} /* clatrz_ */ + diff --git a/lapack-netlib/SRC/clatsqr.c b/lapack-netlib/SRC/clatsqr.c new file mode 100644 index 000000000..a3a014ef7 --- /dev/null +++ b/lapack-netlib/SRC/clatsqr.c @@ -0,0 +1,670 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATSQR */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, */ +/* LWORK, INFO) */ + +/* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK */ +/* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATSQR computes a blocked Tall-Skinny QR factorization of */ +/* > a complex M-by-N matrix A for M >= N: */ +/* > */ +/* > A = Q * ( R ), */ +/* > ( 0 ) */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a M-by-M orthogonal matrix, stored on exit in an implicit */ +/* > form in the elements below the digonal of the array A and in */ +/* > the elemenst of the array T; */ +/* > */ +/* > R is an upper-triangular N-by-N matrix, stored on exit in */ +/* > the elements on and above the diagonal of the array A. */ +/* > */ +/* > 0 is a (M-N)-by-N zero matrix, and is not stored. */ +/* > */ +/* > \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] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The row block size to be used in the blocked QR. */ +/* > MB > N. */ +/* > \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,out] A */ +/* > \verbatim */ +/* > A is COMPLEX 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 N-by-N upper triangular matrix R; */ +/* > the elements below the diagonal represent Q by the columns */ +/* > of blocked V (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] T */ +/* > \verbatim */ +/* > T is COMPLEX array, */ +/* > dimension (LDT, N * Number_of_row_blocks) */ +/* > where Number_of_row_blocks = CEIL((M-N)/(MB-N)) */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. */ +/* > See Further Details below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. LWORK >= NB*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 */ +/* > \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 clatsqr_(integer *m, integer *n, integer *mb, integer * + nb, complex *a, integer *lda, complex *t, integer *ldt, complex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, ii, kk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cgeqrt_( + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *), ctpqrt_(integer *, integer *, + integer *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *); + logical lquery; + integer ctr; + + +/* -- LAPACK computational routine (version 3.9.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* TEST THE INPUT 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 (*mb <= *n) { + *info = -3; + } else if (*nb < 1 || *nb > *n && *n > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldt < *nb) { + *info = -8; + } else if (*lwork < *n * *nb && ! lquery) { + *info = -10; + } + if (*info == 0) { + i__1 = *nb * *n; + work[1].r = (real) i__1, work[1].i = 0.f; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATSQR", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* The QR Decomposition */ + + if (*mb <= *n || *mb >= *m) { + cgeqrt_(m, n, nb, &a[a_offset], lda, &t[t_offset], ldt, &work[1], + info); + return 0; + } + kk = (*m - *n) % (*mb - *n); + ii = *m - kk + 1; + +/* Compute the QR factorization of the first block A(1:MB,1:N) */ + + cgeqrt_(mb, n, nb, &a[a_dim1 + 1], lda, &t[t_offset], ldt, &work[1], info) + ; + ctr = 1; + + i__1 = ii - *mb + *n; + i__2 = *mb - *n; + for (i__ = *mb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block A(I:I+MB-N,1:N) */ + + i__3 = *mb - *n; + ctpqrt_(&i__3, n, &c__0, nb, &a[a_dim1 + 1], lda, &a[i__ + a_dim1], + lda, &t[(ctr * *n + 1) * t_dim1 + 1], ldt, &work[1], info); + ++ctr; + } + +/* Compute the QR factorization of the last block A(II:M,1:N) */ + + if (ii <= *m) { + ctpqrt_(&kk, n, &c__0, nb, &a[a_dim1 + 1], lda, &a[ii + a_dim1], lda, + &t[(ctr * *n + 1) * t_dim1 + 1], ldt, &work[1], info); + } + + i__2 = *n * *nb; + work[1].r = (real) i__2, work[1].i = 0.f; + return 0; + +/* End of CLATSQR */ + +} /* clatsqr_ */ + diff --git a/lapack-netlib/SRC/claunhr_col_getrfnp.c b/lapack-netlib/SRC/claunhr_col_getrfnp.c new file mode 100644 index 000000000..37fedb7a8 --- /dev/null +++ b/lapack-netlib/SRC/claunhr_col_getrfnp.c @@ -0,0 +1,656 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAUNHR_COL_GETRFNP */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLAUNHR_COL_GETRFNP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAUNHR_COL_GETRFNP( M, N, A, LDA, D, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX A( LDA, * ), D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAUNHR_COL_GETRFNP computes the modified LU factorization without */ +/* > pivoting of a complex general M-by-N matrix A. The factorization has */ +/* > the form: */ +/* > */ +/* > A - S = L * U, */ +/* > */ +/* > where: */ +/* > S is a m-by-n diagonal sign matrix with the diagonal D, so that */ +/* > D(i) = S(i,i), 1 <= i <= f2cmin(M,N). The diagonal D is constructed */ +/* > as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing */ +/* > i-1 steps of Gaussian elimination. This means that the diagonal */ +/* > element at each step of "modified" Gaussian elimination is */ +/* > at least one in absolute value (so that division-by-zero not */ +/* > not possible during the division by the diagonal element); */ +/* > */ +/* > L is a M-by-N lower triangular matrix with unit diagonal elements */ +/* > (lower trapezoidal if M > N); */ +/* > */ +/* > and U is a M-by-N upper triangular matrix */ +/* > (upper trapezoidal if M < N). */ +/* > */ +/* > This routine is an auxiliary routine used in the Householder */ +/* > reconstruction routine CUNHR_COL. In CUNHR_COL, this routine is */ +/* > applied to an M-by-N matrix A with orthonormal columns, where each */ +/* > element is bounded by one in absolute value. With the choice of */ +/* > the matrix S above, one can show that the diagonal element at each */ +/* > step of Gaussian elimination is the largest (in absolute value) in */ +/* > the column on or below the diagonal, so that no pivoting is required */ +/* > for numerical stability [1]. */ +/* > */ +/* > For more details on the Householder reconstruction algorithm, */ +/* > including the modified LU factorization, see [1]. */ +/* > */ +/* > This is the blocked right-looking version of the algorithm, */ +/* > calling Level 3 BLAS to update the submatrix. To factorize a block, */ +/* > this routine calls the recursive routine CLAUNHR_COL_GETRFNP2. */ +/* > */ +/* > [1] "Reconstructing Householder vectors from tall-skinny QR", */ +/* > G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, */ +/* > E. Solomonik, J. Parallel Distrib. Comput., */ +/* > vol. 85, pp. 3-31, 2015. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix to be factored. */ +/* > On exit, the factors L and U from the factorization */ +/* > A-S=L*U; the unit diagonal elements of L are not stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension f2cmin(M,N) */ +/* > The diagonal elements of the diagonal M-by-N sign matrix S, */ +/* > D(i) = S(i,i), where 1 <= i <= f2cmin(M,N). The elements can be */ +/* > only ( +1.0, 0.0 ) or (-1.0, 0.0 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ +/* > */ +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complexGEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2019, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int claunhr_col_getrfnp_(integer *m, integer *n, complex *a, + integer *lda, complex *d__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + complex q__1; + + /* Local variables */ + extern /* Subroutine */ int claunhr_col_getrfnp2_(integer *, integer *, + complex *, integer *, complex *, integer *); + integer j; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + integer iinfo; + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer jb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK computational routine (version 3.9.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAUNHR_COL_GETRFNP", &i__1, (ftnlen)19); + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "CLAUNHR_COL_GETRFNP", " ", m, n, &c_n1, &c_n1, ( + ftnlen)19, (ftnlen)1); + if (nb <= 1 || nb >= f2cmin(*m,*n)) { + +/* Use unblocked code. */ + + claunhr_col_getrfnp2_(m, n, &a[a_offset], lda, &d__[1], info); + } else { + +/* Use blocked code. */ + + i__1 = f2cmin(*m,*n); + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = f2cmin(*m,*n) - j + 1; + jb = f2cmin(i__3,nb); + +/* Factor diagonal and subdiagonal blocks. */ + + i__3 = *m - j + 1; + claunhr_col_getrfnp2_(&i__3, &jb, &a[j + j * a_dim1], lda, &d__[ + j], &iinfo); + + if (j + jb <= *n) { + +/* Compute block row of U. */ + + i__3 = *n - j - jb + 1; + ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, & + c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) * + a_dim1], lda); + if (j + jb <= *m) { + +/* Update trailing submatrix. */ + + i__3 = *m - j - jb + 1; + i__4 = *n - j - jb + 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "No transpose", &i__3, &i__4, &jb, + &q__1, &a[j + jb + j * a_dim1], lda, &a[j + (j + + jb) * a_dim1], lda, &c_b1, &a[j + jb + (j + jb) * + a_dim1], lda); + } + } + } + } + return 0; + +/* End of CLAUNHR_COL_GETRFNP */ + +} /* claunhr_col_getrfnp__ */ + diff --git a/lapack-netlib/SRC/claunhr_col_getrfnp2.c b/lapack-netlib/SRC/claunhr_col_getrfnp2.c new file mode 100644 index 000000000..2e5430efc --- /dev/null +++ b/lapack-netlib/SRC/claunhr_col_getrfnp2.c @@ -0,0 +1,728 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAUNHR_COL_GETRFNP2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLAUNHR_COL_GETRFNP2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAUNHR_COL_GETRFNP2( M, N, A, LDA, D, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX A( LDA, * ), D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAUNHR_COL_GETRFNP2 computes the modified LU factorization without */ +/* > pivoting of a complex general M-by-N matrix A. The factorization has */ +/* > the form: */ +/* > */ +/* > A - S = L * U, */ +/* > */ +/* > where: */ +/* > S is a m-by-n diagonal sign matrix with the diagonal D, so that */ +/* > D(i) = S(i,i), 1 <= i <= f2cmin(M,N). The diagonal D is constructed */ +/* > as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing */ +/* > i-1 steps of Gaussian elimination. This means that the diagonal */ +/* > element at each step of "modified" Gaussian elimination is at */ +/* > least one in absolute value (so that division-by-zero not */ +/* > possible during the division by the diagonal element); */ +/* > */ +/* > L is a M-by-N lower triangular matrix with unit diagonal elements */ +/* > (lower trapezoidal if M > N); */ +/* > */ +/* > and U is a M-by-N upper triangular matrix */ +/* > (upper trapezoidal if M < N). */ +/* > */ +/* > This routine is an auxiliary routine used in the Householder */ +/* > reconstruction routine CUNHR_COL. In CUNHR_COL, this routine is */ +/* > applied to an M-by-N matrix A with orthonormal columns, where each */ +/* > element is bounded by one in absolute value. With the choice of */ +/* > the matrix S above, one can show that the diagonal element at each */ +/* > step of Gaussian elimination is the largest (in absolute value) in */ +/* > the column on or below the diagonal, so that no pivoting is required */ +/* > for numerical stability [1]. */ +/* > */ +/* > For more details on the Householder reconstruction algorithm, */ +/* > including the modified LU factorization, see [1]. */ +/* > */ +/* > This is the recursive version of the LU factorization algorithm. */ +/* > Denote A - S by B. The algorithm divides the matrix B into four */ +/* > submatrices: */ +/* > */ +/* > [ B11 | B12 ] where B11 is n1 by n1, */ +/* > B = [ -----|----- ] B21 is (m-n1) by n1, */ +/* > [ B21 | B22 ] B12 is n1 by n2, */ +/* > B22 is (m-n1) by n2, */ +/* > with n1 = f2cmin(m,n)/2, n2 = n-n1. */ +/* > */ +/* > */ +/* > The subroutine calls itself to factor B11, solves for B21, */ +/* > solves for B12, updates B22, then calls itself to factor B22. */ +/* > */ +/* > For more details on the recursive LU algorithm, see [2]. */ +/* > */ +/* > CLAUNHR_COL_GETRFNP2 is called to factorize a block by the blocked */ +/* > routine CLAUNHR_COL_GETRFNP, which uses blocked code calling */ +/* . Level 3 BLAS to update the submatrix. However, CLAUNHR_COL_GETRFNP2 */ +/* > is self-sufficient and can be used without CLAUNHR_COL_GETRFNP. */ +/* > */ +/* > [1] "Reconstructing Householder vectors from tall-skinny QR", */ +/* > G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, */ +/* > E. Solomonik, J. Parallel Distrib. Comput., */ +/* > vol. 85, pp. 3-31, 2015. */ +/* > */ +/* > [2] "Recursion leads to automatic variable blocking for dense linear */ +/* > algebra algorithms", F. Gustavson, IBM J. of Res. and Dev., */ +/* > vol. 41, no. 6, pp. 737-755, 1997. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix to be factored. */ +/* > On exit, the factors L and U from the factorization */ +/* > A-S=L*U; the unit diagonal elements of L are not stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension f2cmin(M,N) */ +/* > The diagonal elements of the diagonal M-by-N sign matrix S, */ +/* > D(i) = S(i,i), where 1 <= i <= f2cmin(M,N). The elements can be */ +/* > only ( +1.0, 0.0 ) or (-1.0, 0.0 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ +/* > */ +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complexGEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2019, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int claunhr_col_getrfnp2_(integer *m, integer *n, complex * + a, integer *lda, complex *d__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1, r__2; + complex q__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), cgemm_(char *, char *, integer *, integer *, integer * + , complex *, complex *, integer *, complex *, integer *, complex * + , complex *, integer *); + integer iinfo; + real sfmin; + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer n1, n2; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.9.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAUNHR_COL_GETRFNP2", &i__1, (ftnlen)20); + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + if (*m == 1) { + +/* One row case, (also recursion termination case), */ +/* use unblocked code */ + +/* Transfer the sign */ + + i__1 = a_dim1 + 1; + r__2 = a[i__1].r; + r__1 = -r_sign(&c_b4, &r__2); + q__1.r = r__1, q__1.i = 0.f; + d__[1].r = q__1.r, d__[1].i = q__1.i; + +/* Construct the row of U */ + + i__1 = a_dim1 + 1; + i__2 = a_dim1 + 1; + q__1.r = a[i__2].r - d__[1].r, q__1.i = a[i__2].i - d__[1].i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + + } else if (*n == 1) { + +/* One column case, (also recursion termination case), */ +/* use unblocked code */ + +/* Transfer the sign */ + + i__1 = a_dim1 + 1; + r__2 = a[i__1].r; + r__1 = -r_sign(&c_b4, &r__2); + q__1.r = r__1, q__1.i = 0.f; + d__[1].r = q__1.r, d__[1].i = q__1.i; + +/* Construct the row of U */ + + i__1 = a_dim1 + 1; + i__2 = a_dim1 + 1; + q__1.r = a[i__2].r - d__[1].r, q__1.i = a[i__2].i - d__[1].i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Scale the elements 2:M of the column */ + +/* Determine machine safe minimum */ + + sfmin = slamch_("S"); + +/* Construct the subdiagonal elements of L */ + + i__1 = a_dim1 + 1; + if ((doublereal) ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[ + a_dim1 + 1]), abs(r__2))) >= sfmin) { + i__1 = *m - 1; + c_div(&q__1, &c_b1, &a[a_dim1 + 1]); + cscal_(&i__1, &q__1, &a[a_dim1 + 2], &c__1); + } else { + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + a_dim1; + c_div(&q__1, &a[i__ + a_dim1], &a[a_dim1 + 1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + } + + } else { + +/* Divide the matrix B into four submatrices */ + + n1 = f2cmin(*m,*n) / 2; + n2 = *n - n1; + +/* Factor B11, recursive call */ + + claunhr_col_getrfnp2_(&n1, &n1, &a[a_offset], lda, &d__[1], &iinfo); + +/* Solve for B21 */ + + i__1 = *m - n1; + ctrsm_("R", "U", "N", "N", &i__1, &n1, &c_b1, &a[a_offset], lda, &a[ + n1 + 1 + a_dim1], lda); + +/* Solve for B12 */ + + ctrsm_("L", "L", "N", "U", &n1, &n2, &c_b1, &a[a_offset], lda, &a[(n1 + + 1) * a_dim1 + 1], lda); + +/* Update B22, i.e. compute the Schur complement */ +/* B22 := B22 - B21*B12 */ + + i__1 = *m - n1; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &i__1, &n2, &n1, &q__1, &a[n1 + 1 + a_dim1], lda, &a[ + (n1 + 1) * a_dim1 + 1], lda, &c_b1, &a[n1 + 1 + (n1 + 1) * + a_dim1], lda); + +/* Factor B22, recursive call */ + + i__1 = *m - n1; + claunhr_col_getrfnp2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], + lda, &d__[n1 + 1], &iinfo); + + } + return 0; + +/* End of CLAUNHR_COL_GETRFNP2 */ + +} /* claunhr_col_getrfnp2__ */ + diff --git a/lapack-netlib/SRC/clauu2.c b/lapack-netlib/SRC/clauu2.c new file mode 100644 index 000000000..58da52396 --- /dev/null +++ b/lapack-netlib/SRC/clauu2.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 CLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (u +nblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLAUU2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAUU2 computes the product U * U**H or L**H * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A. */ +/* > */ +/* > This is the unblocked form of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**H; */ +/* > if UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int clauu2_(char *uplo, integer *n, complex *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1; + complex q__1; + + /* Local variables */ + integer i__; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + logical upper; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + csscal_(integer *, real *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real aii; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAUU2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the product U * U**H. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + aii = a[i__2].r; + if (i__ < *n) { + i__2 = i__ + i__ * a_dim1; + i__3 = *n - i__; + cdotc_(&q__1, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &a[ + i__ + (i__ + 1) * a_dim1], lda); + r__1 = aii * aii + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + i__2 = *n - i__; + clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = i__ - 1; + i__3 = *n - i__; + q__1.r = aii, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &c_b1, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & + q__1, &a[i__ * a_dim1 + 1], &c__1); + i__2 = *n - i__; + clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + } else { + csscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); + } +/* L10: */ + } + + } else { + +/* Compute the product L**H * L. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + aii = a[i__2].r; + if (i__ < *n) { + i__2 = i__ + i__ * a_dim1; + i__3 = *n - i__; + cdotc_(&q__1, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[ + i__ + 1 + i__ * a_dim1], &c__1); + r__1 = aii * aii + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + i__2 = i__ - 1; + clacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = *n - i__; + i__3 = i__ - 1; + q__1.r = aii, q__1.i = 0.f; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a[i__ + 1 + + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & + q__1, &a[i__ + a_dim1], lda); + i__2 = i__ - 1; + clacgv_(&i__2, &a[i__ + a_dim1], lda); + } else { + csscal_(&i__, &aii, &a[i__ + a_dim1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of CLAUU2 */ + +} /* clauu2_ */ + diff --git a/lapack-netlib/SRC/clauum.c b/lapack-netlib/SRC/clauum.c new file mode 100644 index 000000000..a9e4b3010 --- /dev/null +++ b/lapack-netlib/SRC/clauum.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 CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (b +locked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLAUUM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAUUM computes the product U * U**H or L**H * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A. */ +/* > */ +/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**H; */ +/* > if UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int clauum_(char *uplo, integer *n, complex *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *), cherk_(char *, + char *, integer *, integer *, real *, complex *, integer *, real * + , complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + extern /* Subroutine */ int clauu2_(char *, integer *, complex *, integer + *, integer *); + integer ib, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAUUM", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "CLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + clauu2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute the product U * U**H. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + ctrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", & + i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + * a_dim1 + 1], lda); + clauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + cgemm_("No transpose", "Conjugate transpose", &i__3, &ib, + &i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, & + a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ * + a_dim1 + 1], lda); + i__3 = *n - i__ - ib + 1; + cherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[ + i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ + + i__ * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the product L**H * L. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + ctrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", & + ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + + a_dim1], lda); + clauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + cgemm_("Conjugate transpose", "No transpose", &ib, &i__3, + &i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, & + a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1] + , lda); + i__3 = *n - i__ - ib + 1; + cherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21, + &a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__ + + i__ * a_dim1], lda); + } +/* L20: */ + } + } + } + + return 0; + +/* End of CLAUUM */ + +} /* clauum_ */ + diff --git a/lapack-netlib/SRC/cpbcon.c b/lapack-netlib/SRC/cpbcon.c new file mode 100644 index 000000000..d1e3a917f --- /dev/null +++ b/lapack-netlib/SRC/cpbcon.c @@ -0,0 +1,667 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPBCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, */ +/* RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* REAL ANORM, RCOND */ +/* REAL RWORK( * ) */ +/* COMPLEX AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBCON estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex Hermitian positive definite band matrix using */ +/* > the Cholesky factorization A = U**H*U or A = L*L**H computed by */ +/* > CPBTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular factor stored in AB; */ +/* > = 'L': Lower triangular factor stored in AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H of the band matrix A, stored in the */ +/* > first KD+1 rows of the array. The j-th column of U or L is */ +/* > stored in the j-th column of the array AB as follows: */ +/* > if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm (or infinity-norm) of the Hermitian band matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab, + integer *ldab, real *anorm, real *rcond, complex *work, real *rwork, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1; + real r__1, r__2; + + /* Local variables */ + integer kase; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + integer ix; + extern integer icamax_(integer *, complex *, integer *); + real scalel; + extern real slamch_(char *); + extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, + integer *, integer *, complex *, integer *, complex *, real *, + real *, integer *); + real scaleu; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real ainvnm; + extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer + *); + char normin[1]; + real smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } else if (*anorm < 0.f) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm == 0.f) { + return 0; + } + + smlnum = slamch_("Safe minimum"); + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; + *(unsigned char *)normin = 'N'; +L10: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (upper) { + +/* Multiply by inv(U**H). */ + + clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd, + &ab[ab_offset], ldab, &work[1], &scalel, &rwork[1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(U). */ + + clatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scaleu, &rwork[1], info); + } else { + +/* Multiply by inv(L). */ + + clatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scalel, &rwork[1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(L**H). */ + + clatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd, + &ab[ab_offset], ldab, &work[1], &scaleu, &rwork[1], info); + } + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + scale = scalel * scaleu; + if (scale != 1.f) { + ix = icamax_(n, &work[1], &c__1); + i__1 = ix; + if (scale < ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& + work[ix]), abs(r__2))) * smlnum || scale == 0.f) { + goto L20; + } + csrscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + +L20: + + return 0; + +/* End of CPBCON */ + +} /* cpbcon_ */ + diff --git a/lapack-netlib/SRC/cpbequ.c b/lapack-netlib/SRC/cpbequ.c new file mode 100644 index 000000000..b87542846 --- /dev/null +++ b/lapack-netlib/SRC/cpbequ.c @@ -0,0 +1,636 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPBEQU */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBEQU + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* REAL AMAX, SCOND */ +/* REAL S( * ) */ +/* COMPLEX AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBEQU computes row and column scalings intended to equilibrate a */ +/* > Hermitian positive definite band matrix A and reduce its condition */ +/* > number (with respect to the two-norm). S contains the scale factors, */ +/* > S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ +/* > elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ +/* > choice of S puts the condition number of B within a factor N of the */ +/* > smallest possible condition number over all possible diagonal */ +/* > scalings. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular of A is stored; */ +/* > = 'L': Lower triangular of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > The upper or lower triangle of the Hermitian band matrix A, */ +/* > stored in the first KD+1 rows of the array. The j-th column */ +/* > of A is stored in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array A. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > If INFO = 0, S contains the scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* > the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* > large nor too small, it is not worth scaling by S. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, the i-th diagonal element is nonpositive. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpbequ_(char *uplo, integer *n, integer *kd, complex *ab, + integer *ldab, real *s, real *scond, real *amax, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real smin; + integer i__, j; + extern logical lsame_(char *, char *); + logical upper; + 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --s; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBEQU", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *scond = 1.f; + *amax = 0.f; + return 0; + } + + if (upper) { + j = *kd + 1; + } else { + j = 1; + } + +/* Initialize SMIN and AMAX. */ + + i__1 = j + ab_dim1; + s[1] = ab[i__1].r; + smin = s[1]; + *amax = s[1]; + +/* Find the minimum and maximum diagonal elements. */ + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = j + i__ * ab_dim1; + s[i__] = ab[i__2].r; +/* Computing MIN */ + r__1 = smin, r__2 = s[i__]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = *amax, r__2 = s[i__]; + *amax = f2cmax(r__1,r__2); +/* L10: */ + } + + if (smin <= 0.f) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.f) { + *info = i__; + return 0; + } +/* L20: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 1.f / sqrt(s[i__]); +/* L30: */ + } + +/* Compute SCOND = f2cmin(S(I)) / f2cmax(S(I)) */ + + *scond = sqrt(smin) / sqrt(*amax); + } + return 0; + +/* End of CPBEQU */ + +} /* cpbequ_ */ + diff --git a/lapack-netlib/SRC/cpbrfs.c b/lapack-netlib/SRC/cpbrfs.c new file mode 100644 index 000000000..1b9c1a741 --- /dev/null +++ b/lapack-netlib/SRC/cpbrfs.c @@ -0,0 +1,932 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPBRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, */ +/* LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is Hermitian positive definite */ +/* > and banded, and provides error bounds and backward error estimates */ +/* > for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > The upper or lower triangle of the Hermitian band matrix A, */ +/* > stored in the first KD+1 rows of the array. The j-th column */ +/* > of A is stored in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX array, dimension (LDAFB,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H of the band matrix A as computed by */ +/* > CPBTRF, in the same storage format as A (see AB). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by CPBTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpbrfs_(char *uplo, integer *n, integer *kd, integer * + nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, + complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real * + berr, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k, l; + real s; + extern /* Subroutine */ int chbmv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + integer count; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpbtrs_( + char *, integer *, integer *, integer *, complex *, integer *, + complex *, integer *, integer *); + real lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldafb < *kd + 1) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldx < f2cmax(1,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + +/* Computing MIN */ + i__1 = *n + 1, i__2 = (*kd << 1) + 2; + nz = f2cmin(i__1,i__2); + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.f; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + q__1.r = -1.f, q__1.i = 0.f; + chbmv_(uplo, n, kd, &q__1, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], & + c__1, &c_b1, &work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[i__] = (r__1 = b[i__3].r, abs(r__1)) + (r__2 = r_imag(&b[ + i__ + j * b_dim1]), abs(r__2)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + l = *kd + 1 - k; +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k - 1; + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + i__3 = l + i__ + k * ab_dim1; + rwork[i__] += ((r__1 = ab[i__3].r, abs(r__1)) + (r__2 = + r_imag(&ab[l + i__ + k * ab_dim1]), abs(r__2))) * + xk; + i__3 = l + i__ + k * ab_dim1; + i__4 = i__ + j * x_dim1; + s += ((r__1 = ab[i__3].r, abs(r__1)) + (r__2 = r_imag(&ab[ + l + i__ + k * ab_dim1]), abs(r__2))) * ((r__3 = x[ + i__4].r, abs(r__3)) + (r__4 = r_imag(&x[i__ + j * + x_dim1]), abs(r__4))); +/* L40: */ + } + i__5 = *kd + 1 + k * ab_dim1; + rwork[k] = rwork[k] + (r__1 = ab[i__5].r, abs(r__1)) * xk + s; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__5 = k + j * x_dim1; + xk = (r__1 = x[i__5].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + i__5 = k * ab_dim1 + 1; + rwork[k] += (r__1 = ab[i__5].r, abs(r__1)) * xk; + l = 1 - k; +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = f2cmin(i__3,i__4); + for (i__ = k + 1; i__ <= i__5; ++i__) { + i__3 = l + i__ + k * ab_dim1; + rwork[i__] += ((r__1 = ab[i__3].r, abs(r__1)) + (r__2 = + r_imag(&ab[l + i__ + k * ab_dim1]), abs(r__2))) * + xk; + i__3 = l + i__ + k * ab_dim1; + i__4 = i__ + j * x_dim1; + s += ((r__1 = ab[i__3].r, abs(r__1)) + (r__2 = r_imag(&ab[ + l + i__ + k * ab_dim1]), abs(r__2))) * ((r__3 = x[ + i__4].r, abs(r__3)) + (r__4 = r_imag(&x[i__ + j * + x_dim1]), abs(r__4))); +/* L60: */ + } + rwork[k] += s; +/* L70: */ + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__5 = i__; + r__3 = s, r__4 = ((r__1 = work[i__5].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2))) / rwork[i__]; + s = f2cmax(r__3,r__4); + } else { +/* Computing MAX */ + i__5 = i__; + r__3 = s, r__4 = ((r__1 = work[i__5].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(r__3,r__4); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { + +/* Update solution and try again. */ + + cpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1], n, + info); + caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__5 = i__; + rwork[i__] = (r__1 = work[i__5].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + ; + } else { + i__5 = i__; + rwork[i__] = (r__1 = work[i__5].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**H). */ + + cpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1], + n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__5 = i__; + i__3 = i__; + i__4 = i__; + q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3] + * work[i__4].i; + work[i__5].r = q__1.r, work[i__5].i = q__1.i; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__5 = i__; + i__3 = i__; + i__4 = i__; + q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3] + * work[i__4].i; + work[i__5].r = q__1.r, work[i__5].i = q__1.i; +/* L120: */ + } + cpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1], + n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__5 = i__ + j * x_dim1; + r__3 = lstres, r__4 = (r__1 = x[i__5].r, abs(r__1)) + (r__2 = + r_imag(&x[i__ + j * x_dim1]), abs(r__2)); + lstres = f2cmax(r__3,r__4); +/* L130: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of CPBRFS */ + +} /* cpbrfs_ */ + diff --git a/lapack-netlib/SRC/cpbstf.c b/lapack-netlib/SRC/cpbstf.c new file mode 100644 index 000000000..481386f2c --- /dev/null +++ b/lapack-netlib/SRC/cpbstf.c @@ -0,0 +1,759 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPBSTF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBSTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* COMPLEX AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBSTF computes a split Cholesky factorization of a complex */ +/* > Hermitian positive definite band matrix A. */ +/* > */ +/* > This routine is designed to be used in conjunction with CHBGST. */ +/* > */ +/* > The factorization has the form A = S**H*S where S is a band matrix */ +/* > of the same bandwidth as A and the following structure: */ +/* > */ +/* > S = ( U ) */ +/* > ( M L ) */ +/* > */ +/* > where U is upper triangular of order m = (n+kd)/2, and L is lower */ +/* > triangular of order n-m. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the Hermitian band */ +/* > matrix A, stored in the first kd+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, if INFO = 0, the factor S from the split Cholesky */ +/* > factorization A = S**H*S. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the factorization could not be completed, */ +/* > because the updated element a(i,i) was negative; the */ +/* > matrix A is not positive definite. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > N = 7, KD = 2: */ +/* > */ +/* > S = ( s11 s12 s13 ) */ +/* > ( s22 s23 s24 ) */ +/* > ( s33 s34 ) */ +/* > ( s44 ) */ +/* > ( s53 s54 s55 ) */ +/* > ( s64 s65 s66 ) */ +/* > ( s75 s76 s77 ) */ +/* > */ +/* > If UPLO = 'U', the array AB holds: */ +/* > */ +/* > on entry: on exit: */ +/* > */ +/* > * * a13 a24 a35 a46 a57 * * s13 s24 s53**H s64**H s75**H */ +/* > * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54**H s65**H s76**H */ +/* > a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */ +/* > */ +/* > If UPLO = 'L', the array AB holds: */ +/* > */ +/* > on entry: on exit: */ +/* > */ +/* > a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */ +/* > a21 a32 a43 a54 a65 a76 * s12**H s23**H s34**H s54 s65 s76 * */ +/* > a31 a42 a53 a64 a64 * * s13**H s24**H s53 s64 s75 * * */ +/* > */ +/* > Array elements marked * are not used by the routine; s12**H denotes */ +/* > conjg(s12); the diagonal elements of S are real. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cpbstf_(char *uplo, integer *n, integer *kd, complex *ab, + integer *ldab, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int cher_(char *, integer *, real *, complex *, + integer *, complex *, integer *); + integer j, m; + extern logical lsame_(char *, char *); + logical upper; + integer km; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + csscal_(integer *, real *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real ajj; + integer kld; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBSTF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = 1, i__2 = *ldab - 1; + kld = f2cmax(i__1,i__2); + +/* Set the splitting point m. */ + + m = (*n + *kd) / 2; + + if (upper) { + +/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */ + + i__1 = m + 1; + for (j = *n; j >= i__1; --j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + i__2 = *kd + 1 + j * ab_dim1; + ajj = ab[i__2].r; + if (ajj <= 0.f) { + i__2 = *kd + 1 + j * ab_dim1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + goto L50; + } + ajj = sqrt(ajj); + i__2 = *kd + 1 + j * ab_dim1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; +/* Computing MIN */ + i__2 = j - 1; + km = f2cmin(i__2,*kd); + +/* Compute elements j-km:j-1 of the j-th column and update the */ +/* the leading submatrix within the band. */ + + r__1 = 1.f / ajj; + csscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1); + cher_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1, + &ab[*kd + 1 + (j - km) * ab_dim1], &kld); +/* L10: */ + } + +/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */ + + i__1 = m; + for (j = 1; j <= i__1; ++j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + i__2 = *kd + 1 + j * ab_dim1; + ajj = ab[i__2].r; + if (ajj <= 0.f) { + i__2 = *kd + 1 + j * ab_dim1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + goto L50; + } + ajj = sqrt(ajj); + i__2 = *kd + 1 + j * ab_dim1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; +/* Computing MIN */ + i__2 = *kd, i__3 = m - j; + km = f2cmin(i__2,i__3); + +/* Compute elements j+1:j+km of the j-th row and update the */ +/* trailing submatrix within the band. */ + + if (km > 0) { + r__1 = 1.f / ajj; + csscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld); + clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld); + cher_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld, + &ab[*kd + 1 + (j + 1) * ab_dim1], &kld); + clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld); + } +/* L20: */ + } + } else { + +/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */ + + i__1 = m + 1; + for (j = *n; j >= i__1; --j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + i__2 = j * ab_dim1 + 1; + ajj = ab[i__2].r; + if (ajj <= 0.f) { + i__2 = j * ab_dim1 + 1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + goto L50; + } + ajj = sqrt(ajj); + i__2 = j * ab_dim1 + 1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; +/* Computing MIN */ + i__2 = j - 1; + km = f2cmin(i__2,*kd); + +/* Compute elements j-km:j-1 of the j-th row and update the */ +/* trailing submatrix within the band. */ + + r__1 = 1.f / ajj; + csscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld); + clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld); + cher_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld, + &ab[(j - km) * ab_dim1 + 1], &kld); + clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld); +/* L30: */ + } + +/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */ + + i__1 = m; + for (j = 1; j <= i__1; ++j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + i__2 = j * ab_dim1 + 1; + ajj = ab[i__2].r; + if (ajj <= 0.f) { + i__2 = j * ab_dim1 + 1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + goto L50; + } + ajj = sqrt(ajj); + i__2 = j * ab_dim1 + 1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; +/* Computing MIN */ + i__2 = *kd, i__3 = m - j; + km = f2cmin(i__2,i__3); + +/* Compute elements j+1:j+km of the j-th column and update the */ +/* trailing submatrix within the band. */ + + if (km > 0) { + r__1 = 1.f / ajj; + csscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1); + cher_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[( + j + 1) * ab_dim1 + 1], &kld); + } +/* L40: */ + } + } + return 0; + +L50: + *info = j; + return 0; + +/* End of CPBSTF */ + +} /* cpbstf_ */ + diff --git a/lapack-netlib/SRC/cpbsv.c b/lapack-netlib/SRC/cpbsv.c new file mode 100644 index 000000000..f4dd03a14 --- /dev/null +++ b/lapack-netlib/SRC/cpbsv.c @@ -0,0 +1,622 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPBSV computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, N, NRHS */ +/* COMPLEX AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian positive definite band matrix and X */ +/* > and B are N-by-NRHS matrices. */ +/* > */ +/* > The Cholesky decomposition is used to factor A as */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular band matrix, and L is a lower */ +/* > triangular band matrix, with the same number of superdiagonals or */ +/* > subdiagonals as A. The factored form of A is then used to solve the */ +/* > system of equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the Hermitian band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for f2cmax(1,j-KD)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(N,j+KD). */ +/* > See below for further details. */ +/* > */ +/* > On exit, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**H*U or A = L*L**H of the band */ +/* > matrix A, in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i of A is not */ +/* > positive definite, so the factorization could not be */ +/* > completed, and the solution has not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > N = 6, KD = 2, and UPLO = 'U': */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > */ +/* > Similarly, if UPLO = 'L' the format of A is as follows: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ +/* > a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ +/* > a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cpbsv_(char *uplo, integer *n, integer *kd, integer * + nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpbtrf_( + char *, integer *, integer *, complex *, integer *, integer *), cpbtrs_(char *, integer *, integer *, integer *, complex + *, integer *, complex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the Cholesky factorization A = U**H*U or A = L*L**H. */ + + cpbtrf_(uplo, n, kd, &ab[ab_offset], ldab, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + cpbtrs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &b[b_offset], ldb, + info); + + } + return 0; + +/* End of CPBSV */ + +} /* cpbsv_ */ + diff --git a/lapack-netlib/SRC/cpbsvx.c b/lapack-netlib/SRC/cpbsvx.c new file mode 100644 index 000000000..7ab40fe18 --- /dev/null +++ b/lapack-netlib/SRC/cpbsvx.c @@ -0,0 +1,1004 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, */ +/* EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, */ +/* WORK, RWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, UPLO */ +/* INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS */ +/* REAL RCOND */ +/* REAL BERR( * ), FERR( * ), RWORK( * ), S( * ) */ +/* COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */ +/* > compute the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian positive definite band matrix and X */ +/* > and B are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* > factor the matrix A (after equilibration if FACT = 'E') as */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular band matrix, and L is a lower */ +/* > triangular band matrix. */ +/* > */ +/* > 3. If the leading i-by-i principal minor is not positive definite, */ +/* > then the routine returns with INFO = i. Otherwise, the factored */ +/* > form of A is used to estimate the condition number of the matrix */ +/* > A. If the reciprocal of the condition number is less than machine */ +/* > precision, INFO = N+1 is returned as a warning, but the routine */ +/* > still goes on to solve for X and compute error bounds as */ +/* > described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(S) so that it solves the original system before */ +/* > equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AFB contains the factored form of A. */ +/* > If EQUED = 'Y', the matrix A has been equilibrated */ +/* > with scaling factors given by S. AB and AFB will not */ +/* > be modified. */ +/* > = 'N': The matrix A will be copied to AFB and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AFB and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the Hermitian band */ +/* > matrix A, stored in the first KD+1 rows of the array, except */ +/* > if FACT = 'F' and EQUED = 'Y', then A must contain the */ +/* > equilibrated matrix diag(S)*A*diag(S). The j-th column of A */ +/* > is stored in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for f2cmax(1,j-KD)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(N,j+KD). */ +/* > See below for further details. */ +/* > */ +/* > On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* > diag(S)*A*diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array A. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX array, dimension (LDAFB,N) */ +/* > If FACT = 'F', then AFB is an input argument and on entry */ +/* > contains the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H of the band matrix */ +/* > A, in the same storage format as A (see AB). If EQUED = 'Y', */ +/* > then AFB is the factored form of the equilibrated matrix A. */ +/* > */ +/* > If FACT = 'N', then AFB is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H. */ +/* > */ +/* > If FACT = 'E', then AFB is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H of the equilibrated */ +/* > matrix A (see the description of A for the form of the */ +/* > equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The scale factors for A; not accessed if EQUED = 'N'. S is */ +/* > an input argument if FACT = 'F'; otherwise, S is an output */ +/* > argument. If FACT = 'F' and EQUED = 'Y', each element of S */ +/* > must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ +/* > B is overwritten by diag(S) * B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ +/* > the original system of equations. Note that if EQUED = 'Y', */ +/* > A and B are modified on exit, and the solution to the */ +/* > equilibrated system is inv(diag(S))*X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The estimate of the reciprocal condition number of the matrix */ +/* > A after equilibration (if done). If RCOND is less than the */ +/* > machine precision (in particular, if RCOND = 0), the matrix */ +/* > is singular to working precision. This condition is */ +/* > indicated by a return code of INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the leading minor of order i of A is */ +/* > not positive definite, so the factorization */ +/* > could not be completed, and the solution has not */ +/* > been computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > N = 6, KD = 2, and UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the Hermitian matrix A: */ +/* > */ +/* > a11 a12 a13 */ +/* > a22 a23 a24 */ +/* > a33 a34 a35 */ +/* > a44 a45 a46 */ +/* > a55 a56 */ +/* > (aij=conjg(aji)) a66 */ +/* > */ +/* > Band storage of the upper triangle of A: */ +/* > */ +/* > * * a13 a24 a35 a46 */ +/* > * a12 a23 a34 a45 a56 */ +/* > a11 a22 a33 a44 a55 a66 */ +/* > */ +/* > Similarly, if UPLO = 'L' the format of A is as follows: */ +/* > */ +/* > a11 a22 a33 a44 a55 a66 */ +/* > a21 a32 a43 a54 a65 * */ +/* > a31 a42 a53 a64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cpbsvx_(char *fact, char *uplo, integer *n, integer *kd, + integer *nrhs, complex *ab, integer *ldab, complex *afb, integer * + ldafb, char *equed, real *s, complex *b, integer *ldb, complex *x, + integer *ldx, real *rcond, real *ferr, real *berr, complex *work, + real *rwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2; + complex q__1; + + /* Local variables */ + real amax, smin, smax; + integer i__, j; + extern logical lsame_(char *, char *); + real scond, anorm; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + logical equil, rcequ, upper; + integer j1, j2; + extern real clanhb_(char *, char *, integer *, integer *, complex *, + integer *, real *); + extern /* Subroutine */ int claqhb_(char *, integer *, integer *, complex + *, integer *, real *, real *, real *, char *), + cpbcon_(char *, integer *, integer *, complex *, integer *, real * + , real *, complex *, real *, integer *); + extern real slamch_(char *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen), cpbequ_(char *, integer *, integer *, complex + *, integer *, real *, real *, real *, integer *), cpbrfs_( + char *, integer *, integer *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + real *, real *, complex *, real *, integer *); + real bignum; + extern /* Subroutine */ int cpbtrf_(char *, integer *, integer *, complex + *, integer *, integer *); + integer infequ; + extern /* Subroutine */ int cpbtrs_(char *, integer *, integer *, integer + *, complex *, integer *, complex *, integer *, integer *); + real smlnum; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + upper = lsame_(uplo, "U"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = FALSE_; + } else { + rcequ = lsame_(equed, "Y"); + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } else if (*ldafb < *kd + 1) { + *info = -9; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -10; + } else { + if (rcequ) { + smin = bignum; + smax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = smin, r__2 = s[j]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = smax, r__2 = s[j]; + smax = f2cmax(r__1,r__2); +/* L10: */ + } + if (smin <= 0.f) { + *info = -11; + } else if (*n > 0) { + scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + } else { + scond = 1.f; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldx < f2cmax(1,*n)) { + *info = -15; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBSVX", &i__1, (ftnlen)6); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + cpbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, & + infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + claqhb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, + equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__; + i__5 = i__ + j * b_dim1; + q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L20: */ + } +/* L30: */ + } + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization A = U**H *U or A = L*L**H. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *kd; + j1 = f2cmax(i__2,1); + i__2 = j - j1 + 1; + ccopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, & + afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1); +/* L40: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + *kd; + j2 = f2cmin(i__2,*n); + i__2 = j2 - j + 1; + ccopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1 + + 1], &c__1); +/* L50: */ + } + } + + cpbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.f; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = clanhb_("1", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]); + +/* Compute the reciprocal of the condition number of A. */ + + cpbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], & + rwork[1], info); + +/* Compute the solution matrix X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + cpbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx, + info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + cpbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, + &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] + , &rwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = i__; + i__5 = i__ + j * x_dim1; + q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L60: */ + } +/* L70: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= scond; +/* L80: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < slamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of CPBSVX */ + +} /* cpbsvx_ */ + diff --git a/lapack-netlib/SRC/cpbtf2.c b/lapack-netlib/SRC/cpbtf2.c new file mode 100644 index 000000000..6bbc9d3c2 --- /dev/null +++ b/lapack-netlib/SRC/cpbtf2.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 CPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matr +ix (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* COMPLEX AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBTF2 computes the Cholesky factorization of a complex Hermitian */ +/* > positive definite band matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**H * U , if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix, U**H is the conjugate transpose */ +/* > of U, and L is lower triangular. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* > or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the Hermitian band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**H *U or A = L*L**H of the band */ +/* > matrix A, in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, the leading minor of order k is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > N = 6, KD = 2, and UPLO = 'U': */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > */ +/* > Similarly, if UPLO = 'L' the format of A is as follows: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ +/* > a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ +/* > a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab, + integer *ldab, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int cher_(char *, integer *, real *, complex *, + integer *, complex *, integer *); + integer j; + extern logical lsame_(char *, char *); + logical upper; + integer kn; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + csscal_(integer *, real *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real ajj; + integer kld; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBTF2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = 1, i__2 = *ldab - 1; + kld = f2cmax(i__1,i__2); + + if (upper) { + +/* Compute the Cholesky factorization A = U**H * U. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute U(J,J) and test for non-positive-definiteness. */ + + i__2 = *kd + 1 + j * ab_dim1; + ajj = ab[i__2].r; + if (ajj <= 0.f) { + i__2 = *kd + 1 + j * ab_dim1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + goto L30; + } + ajj = sqrt(ajj); + i__2 = *kd + 1 + j * ab_dim1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + +/* Compute elements J+1:J+KN of row J and update the */ +/* trailing submatrix within the band. */ + +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + kn = f2cmin(i__2,i__3); + if (kn > 0) { + r__1 = 1.f / ajj; + csscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld); + clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld); + cher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld, + &ab[*kd + 1 + (j + 1) * ab_dim1], &kld); + clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld); + } +/* L10: */ + } + } else { + +/* Compute the Cholesky factorization A = L*L**H. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute L(J,J) and test for non-positive-definiteness. */ + + i__2 = j * ab_dim1 + 1; + ajj = ab[i__2].r; + if (ajj <= 0.f) { + i__2 = j * ab_dim1 + 1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + goto L30; + } + ajj = sqrt(ajj); + i__2 = j * ab_dim1 + 1; + ab[i__2].r = ajj, ab[i__2].i = 0.f; + +/* Compute elements J+1:J+KN of column J and update the */ +/* trailing submatrix within the band. */ + +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + kn = f2cmin(i__2,i__3); + if (kn > 0) { + r__1 = 1.f / ajj; + csscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1); + cher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[( + j + 1) * ab_dim1 + 1], &kld); + } +/* L20: */ + } + } + return 0; + +L30: + *info = j; + return 0; + +/* End of CPBTF2 */ + +} /* cpbtf2_ */ + diff --git a/lapack-netlib/SRC/cpbtrf.c b/lapack-netlib/SRC/cpbtrf.c new file mode 100644 index 000000000..96a8799f6 --- /dev/null +++ b/lapack-netlib/SRC/cpbtrf.c @@ -0,0 +1,921 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPBTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* COMPLEX AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBTRF computes the Cholesky factorization of a complex Hermitian */ +/* > positive definite band matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the Hermitian band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**H*U or A = L*L**H of the band */ +/* > matrix A, in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > N = 6, KD = 2, and UPLO = 'U': */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > */ +/* > Similarly, if UPLO = 'L' the format of A is as follows: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ +/* > a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ +/* > a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */ + +/* ===================================================================== */ +/* Subroutine */ int cpbtrf_(char *uplo, integer *n, integer *kd, complex *ab, + integer *ldab, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + complex q__1; + + /* Local variables */ + complex work[1056] /* was [33][32] */; + integer i__, j; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *), cherk_(char *, + char *, integer *, integer *, real *, complex *, integer *, real * + , complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer i2, i3; + extern /* Subroutine */ int cpbtf2_(char *, integer *, integer *, complex + *, integer *, integer *), cpotf2_(char *, integer *, + complex *, integer *, integer *); + integer ib, nb, ii, jj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment */ + + nb = ilaenv_(&c__1, "CPBTRF", uplo, n, kd, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + +/* The block size must not exceed the semi-bandwidth KD, and must not */ +/* exceed the limit set by the size of the local array WORK. */ + + nb = f2cmin(nb,32); + + if (nb <= 1 || nb > *kd) { + +/* Use unblocked code */ + + cpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info); + } else { + +/* Use blocked code */ + + if (lsame_(uplo, "U")) { + +/* Compute the Cholesky factorization of a Hermitian band */ +/* matrix, given the upper triangle of the matrix in band */ +/* storage. */ + +/* Zero the upper triangle of the work array. */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * 33 - 34; + work[i__3].r = 0.f, work[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + +/* Process the band matrix one diagonal block at a time. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + +/* Factorize the diagonal block */ + + i__3 = *ldab - 1; + cpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii); + if (ii != 0) { + *info = i__ + ii - 1; + goto L150; + } + if (i__ + ib <= *n) { + +/* Update the relevant part of the trailing submatrix. */ +/* If A11 denotes the diagonal block which has just been */ +/* factorized, then we need to update the remaining */ +/* blocks in the diagram: */ + +/* A11 A12 A13 */ +/* A22 A23 */ +/* A33 */ + +/* The numbers of rows and columns in the partitioning */ +/* are IB, I2, I3 respectively. The blocks A12, A22 and */ +/* A23 are empty if IB = KD. The upper triangle of A13 */ +/* lies outside the band. */ + +/* Computing MIN */ + i__3 = *kd - ib, i__4 = *n - i__ - ib + 1; + i2 = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = ib, i__4 = *n - i__ - *kd + 1; + i3 = f2cmin(i__3,i__4); + + if (i2 > 0) { + +/* Update A12 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + ctrsm_("Left", "Upper", "Conjugate transpose", "Non-" + "unit", &ib, &i2, &c_b1, &ab[*kd + 1 + i__ * + ab_dim1], &i__3, &ab[*kd + 1 - ib + (i__ + ib) + * ab_dim1], &i__4); + +/* Update A22 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + cherk_("Upper", "Conjugate transpose", &i2, &ib, & + c_b21, &ab[*kd + 1 - ib + (i__ + ib) * + ab_dim1], &i__3, &c_b22, &ab[*kd + 1 + (i__ + + ib) * ab_dim1], &i__4); + } + + if (i3 > 0) { + +/* Copy the lower triangle of A13 into the work array. */ + + i__3 = i3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = ib; + for (ii = jj; ii <= i__4; ++ii) { + i__5 = ii + jj * 33 - 34; + i__6 = ii - jj + 1 + (jj + i__ + *kd - 1) * + ab_dim1; + work[i__5].r = ab[i__6].r, work[i__5].i = ab[ + i__6].i; +/* L30: */ + } +/* L40: */ + } + +/* Update A13 (in the work array). */ + + i__3 = *ldab - 1; + ctrsm_("Left", "Upper", "Conjugate transpose", "Non-" + "unit", &ib, &i3, &c_b1, &ab[*kd + 1 + i__ * + ab_dim1], &i__3, work, &c__33); + +/* Update A23 */ + + if (i2 > 0) { + q__1.r = -1.f, q__1.i = 0.f; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + cgemm_("Conjugate transpose", "No transpose", &i2, + &i3, &ib, &q__1, &ab[*kd + 1 - ib + (i__ + + ib) * ab_dim1], &i__3, work, &c__33, & + c_b1, &ab[ib + 1 + (i__ + *kd) * ab_dim1], + &i__4); + } + +/* Update A33 */ + + i__3 = *ldab - 1; + cherk_("Upper", "Conjugate transpose", &i3, &ib, & + c_b21, work, &c__33, &c_b22, &ab[*kd + 1 + ( + i__ + *kd) * ab_dim1], &i__3); + +/* Copy the lower triangle of A13 back into place. */ + + i__3 = i3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = ib; + for (ii = jj; ii <= i__4; ++ii) { + i__5 = ii - jj + 1 + (jj + i__ + *kd - 1) * + ab_dim1; + i__6 = ii + jj * 33 - 34; + ab[i__5].r = work[i__6].r, ab[i__5].i = work[ + i__6].i; +/* L50: */ + } +/* L60: */ + } + } + } +/* L70: */ + } + } else { + +/* Compute the Cholesky factorization of a Hermitian band */ +/* matrix, given the lower triangle of the matrix in band */ +/* storage. */ + +/* Zero the lower triangle of the work array. */ + + i__2 = nb; + for (j = 1; j <= i__2; ++j) { + i__1 = nb; + for (i__ = j + 1; i__ <= i__1; ++i__) { + i__3 = i__ + j * 33 - 34; + work[i__3].r = 0.f, work[i__3].i = 0.f; +/* L80: */ + } +/* L90: */ + } + +/* Process the band matrix one diagonal block at a time. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + +/* Factorize the diagonal block */ + + i__3 = *ldab - 1; + cpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii); + if (ii != 0) { + *info = i__ + ii - 1; + goto L150; + } + if (i__ + ib <= *n) { + +/* Update the relevant part of the trailing submatrix. */ +/* If A11 denotes the diagonal block which has just been */ +/* factorized, then we need to update the remaining */ +/* blocks in the diagram: */ + +/* A11 */ +/* A21 A22 */ +/* A31 A32 A33 */ + +/* The numbers of rows and columns in the partitioning */ +/* are IB, I2, I3 respectively. The blocks A21, A22 and */ +/* A32 are empty if IB = KD. The lower triangle of A31 */ +/* lies outside the band. */ + +/* Computing MIN */ + i__3 = *kd - ib, i__4 = *n - i__ - ib + 1; + i2 = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = ib, i__4 = *n - i__ - *kd + 1; + i3 = f2cmin(i__3,i__4); + + if (i2 > 0) { + +/* Update A21 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + ctrsm_("Right", "Lower", "Conjugate transpose", "Non" + "-unit", &i2, &ib, &c_b1, &ab[i__ * ab_dim1 + + 1], &i__3, &ab[ib + 1 + i__ * ab_dim1], &i__4); + +/* Update A22 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + cherk_("Lower", "No transpose", &i2, &ib, &c_b21, &ab[ + ib + 1 + i__ * ab_dim1], &i__3, &c_b22, &ab[( + i__ + ib) * ab_dim1 + 1], &i__4); + } + + if (i3 > 0) { + +/* Copy the upper triangle of A31 into the work array. */ + + i__3 = ib; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = f2cmin(jj,i3); + for (ii = 1; ii <= i__4; ++ii) { + i__5 = ii + jj * 33 - 34; + i__6 = *kd + 1 - jj + ii + (jj + i__ - 1) * + ab_dim1; + work[i__5].r = ab[i__6].r, work[i__5].i = ab[ + i__6].i; +/* L100: */ + } +/* L110: */ + } + +/* Update A31 (in the work array). */ + + i__3 = *ldab - 1; + ctrsm_("Right", "Lower", "Conjugate transpose", "Non" + "-unit", &i3, &ib, &c_b1, &ab[i__ * ab_dim1 + + 1], &i__3, work, &c__33); + +/* Update A32 */ + + if (i2 > 0) { + q__1.r = -1.f, q__1.i = 0.f; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + cgemm_("No transpose", "Conjugate transpose", &i3, + &i2, &ib, &q__1, work, &c__33, &ab[ib + + 1 + i__ * ab_dim1], &i__3, &c_b1, &ab[*kd + + 1 - ib + (i__ + ib) * ab_dim1], &i__4); + } + +/* Update A33 */ + + i__3 = *ldab - 1; + cherk_("Lower", "No transpose", &i3, &ib, &c_b21, + work, &c__33, &c_b22, &ab[(i__ + *kd) * + ab_dim1 + 1], &i__3); + +/* Copy the upper triangle of A31 back into place. */ + + i__3 = ib; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = f2cmin(jj,i3); + for (ii = 1; ii <= i__4; ++ii) { + i__5 = *kd + 1 - jj + ii + (jj + i__ - 1) * + ab_dim1; + i__6 = ii + jj * 33 - 34; + ab[i__5].r = work[i__6].r, ab[i__5].i = work[ + i__6].i; +/* L120: */ + } +/* L130: */ + } + } + } +/* L140: */ + } + } + } + return 0; + +L150: + return 0; + +/* End of CPBTRF */ + +} /* cpbtrf_ */ + diff --git a/lapack-netlib/SRC/cpbtrs.c b/lapack-netlib/SRC/cpbtrs.c new file mode 100644 index 000000000..220f8f203 --- /dev/null +++ b/lapack-netlib/SRC/cpbtrs.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 CPBTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPBTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, N, NRHS */ +/* COMPLEX AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPBTRS solves a system of linear equations A*X = B with a Hermitian */ +/* > positive definite band matrix A using the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H computed by CPBTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular factor stored in AB; */ +/* > = 'L': Lower triangular factor stored in AB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX array, dimension (LDAB,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H of the band matrix A, stored in the */ +/* > first KD+1 rows of the array. The j-th column of U or L is */ +/* > stored in the j-th column of the array AB as follows: */ +/* > if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpbtrs_(char *uplo, integer *n, integer *kd, integer * + nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *); + logical upper; + 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPBTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B where A = U**H *U. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve U**H *X = B, overwriting B with X. */ + + ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, kd, &ab[ + ab_offset], ldab, &b[j * b_dim1 + 1], &c__1); + +/* Solve U*X = B, overwriting B with X. */ + + ctbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset], + ldab, &b[j * b_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Solve A*X = B where A = L*L**H. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve L*X = B, overwriting B with X. */ + + ctbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset], + ldab, &b[j * b_dim1 + 1], &c__1); + +/* Solve L**H *X = B, overwriting B with X. */ + + ctbsv_("Lower", "Conjugate transpose", "Non-unit", n, kd, &ab[ + ab_offset], ldab, &b[j * b_dim1 + 1], &c__1); +/* L20: */ + } + } + + return 0; + +/* End of CPBTRS */ + +} /* cpbtrs_ */ + diff --git a/lapack-netlib/SRC/cpftrf.c b/lapack-netlib/SRC/cpftrf.c new file mode 100644 index 000000000..7e304a0e7 --- /dev/null +++ b/lapack-netlib/SRC/cpftrf.c @@ -0,0 +1,887 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPFTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPFTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER N, INFO */ +/* COMPLEX A( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPFTRF computes the Cholesky factorization of a complex Hermitian */ +/* > positive definite matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular. */ +/* > */ +/* > This is the block version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal TRANSR of RFP A is stored; */ +/* > = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of RFP A is stored; */ +/* > = 'L': Lower triangle of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( N*(N+1)/2 ); */ +/* > On entry, the Hermitian matrix A in RFP format. RFP format is */ +/* > described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ +/* > then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ +/* > (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */ +/* > the Conjugate-transpose of RFP A as defined when */ +/* > TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ +/* > follows: If UPLO = 'U' the RFP A contains the nt elements of */ +/* > upper packed A. If UPLO = 'L' the RFP A contains the elements */ +/* > of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */ +/* > 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */ +/* > is odd. See the Note below for more details. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization RFP A = U**H*U or RFP A = L*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > */ +/* > Further Notes on RFP Format: */ +/* > ============================ */ +/* > */ +/* > We first consider Standard Packed 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 */ +/* > conjugate-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 */ +/* > conjugate-transpose of the last three columns of AP lower. */ +/* > To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > 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 next consider Standard Packed 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 */ +/* > conjugate-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 */ +/* > conjugate-transpose of the last two columns of AP lower. */ +/* > To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > 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 */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpftrf_(char *transr, char *uplo, integer *n, complex *a, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer k; + logical normaltransr; + extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *, + real *, complex *, integer *, real *, complex *, integer *); + extern logical lsame_(char *, char *); + logical lower; + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer n1, n2; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer + *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "C")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPFTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + } else { + nisodd = TRUE_; + } + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1) */ + + cpotrf_("L", &n1, a, n, info); + if (*info > 0) { + return 0; + } + ctrsm_("R", "L", "C", "N", &n2, &n1, &c_b1, a, n, &a[n1], n); + cherk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b16, &a[*n], + n); + cpotrf_("U", &n2, &a[*n], n, info); + if (*info > 0) { + *info += n1; + } + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + cpotrf_("L", &n1, &a[n2], n, info); + if (*info > 0) { + return 0; + } + ctrsm_("L", "L", "N", "N", &n1, &n2, &c_b1, &a[n2], n, a, n); + cherk_("U", "C", &n2, &n1, &c_b15, a, n, &c_b16, &a[n1], n); + cpotrf_("U", &n2, &a[n1], n, info); + if (*info > 0) { + *info += n1; + } + + } + + } else { + +/* N is odd and TRANSR = 'C' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ +/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ + + cpotrf_("U", &n1, a, &n1, info); + if (*info > 0) { + return 0; + } + ctrsm_("L", "U", "C", "N", &n1, &n2, &c_b1, a, &n1, &a[n1 * + n1], &n1); + cherk_("L", "C", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b16, & + a[1], &n1); + cpotrf_("L", &n2, &a[1], &n1, info); + if (*info > 0) { + *info += n1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ +/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ + + cpotrf_("U", &n1, &a[n2 * n2], &n2, info); + if (*info > 0) { + return 0; + } + ctrsm_("R", "U", "N", "N", &n2, &n1, &c_b1, &a[n2 * n2], &n2, + a, &n2); + cherk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b16, &a[n1 * n2] + , &n2); + cpotrf_("L", &n2, &a[n1 * n2], &n2, info); + if (*info > 0) { + *info += n1; + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + i__1 = *n + 1; + cpotrf_("L", &k, &a[1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + ctrsm_("R", "L", "C", "N", &k, &k, &c_b1, &a[1], &i__1, &a[k + + 1], &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + cherk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b16, a, + &i__2); + i__1 = *n + 1; + cpotrf_("U", &k, a, &i__1, info); + if (*info > 0) { + *info += k; + } + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + i__1 = *n + 1; + cpotrf_("L", &k, &a[k + 1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + ctrsm_("L", "L", "N", "N", &k, &k, &c_b1, &a[k + 1], &i__1, a, + &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + cherk_("U", "C", &k, &k, &c_b15, a, &i__1, &c_b16, &a[k], & + i__2); + i__1 = *n + 1; + cpotrf_("U", &k, &a[k], &i__1, info); + if (*info > 0) { + *info += k; + } + + } + + } else { + +/* N is even and TRANSR = 'C' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + cpotrf_("U", &k, &a[k], &k, info); + if (*info > 0) { + return 0; + } + ctrsm_("L", "U", "C", "N", &k, &k, &c_b1, &a[k], &n1, &a[k * ( + k + 1)], &k); + cherk_("L", "C", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b16, + a, &k); + cpotrf_("L", &k, a, &k, info); + if (*info > 0) { + *info += k; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + cpotrf_("U", &k, &a[k * (k + 1)], &k, info); + if (*info > 0) { + return 0; + } + ctrsm_("R", "U", "N", "N", &k, &k, &c_b1, &a[k * (k + 1)], &k, + a, &k); + cherk_("L", "N", &k, &k, &c_b15, a, &k, &c_b16, &a[k * k], &k); + cpotrf_("L", &k, &a[k * k], &k, info); + if (*info > 0) { + *info += k; + } + + } + + } + + } + + return 0; + +/* End of CPFTRF */ + +} /* cpftrf_ */ + diff --git a/lapack-netlib/SRC/cpftri.c b/lapack-netlib/SRC/cpftri.c new file mode 100644 index 000000000..dc53dc8d6 --- /dev/null +++ b/lapack-netlib/SRC/cpftri.c @@ -0,0 +1,847 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPFTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPFTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N */ +/* COMPLEX A( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPFTRI computes the inverse of a complex Hermitian positive definite */ +/* > matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */ +/* > computed by CPFTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal TRANSR of RFP A is stored; */ +/* > = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( N*(N+1)/2 ); */ +/* > On entry, the Hermitian matrix A in RFP format. RFP format is */ +/* > described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ +/* > then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ +/* > (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */ +/* > the Conjugate-transpose of RFP A as defined when */ +/* > TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ +/* > follows: If UPLO = 'U' the RFP A contains the nt elements of */ +/* > upper packed A. If UPLO = 'L' the RFP A contains the elements */ +/* > of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */ +/* > 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */ +/* > is odd. See the Note below for more details. */ +/* > */ +/* > On exit, the Hermitian inverse of the original matrix, in the */ +/* > same storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the (i,i) element of the factor U or L is */ +/* > zero, and the inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Standard Packed 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 */ +/* > conjugate-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 */ +/* > conjugate-transpose of the last three columns of AP lower. */ +/* > To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > 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 next consider Standard Packed 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 */ +/* > conjugate-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 */ +/* > conjugate-transpose of the last two columns of AP lower. */ +/* > To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cpftri_(char *transr, char *uplo, integer *n, complex *a, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer k; + logical normaltransr; + extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *, + real *, complex *, integer *, real *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical lower; + integer n1, n2; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + extern /* Subroutine */ int clauum_(char *, integer *, complex *, integer + *, integer *), ctftri_(char *, char *, char *, integer *, + complex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "C")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPFTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Invert the triangular Cholesky factor U or L. */ + + ctftri_(transr, uplo, "N", n, a, info); + if (*info > 0) { + return 0; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + } else { + nisodd = TRUE_; + } + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */ +/* inv(L)^C*inv(L). There are eight cases. */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(N1) */ + + clauum_("L", &n1, a, n, info); + cherk_("L", "C", &n1, &n2, &c_b12, &a[n1], n, &c_b12, a, n); + ctrmm_("L", "U", "N", "N", &n2, &n1, &c_b1, &a[*n], n, &a[n1], + n); + clauum_("U", &n2, &a[*n], n, info); + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */ +/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */ +/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */ + + clauum_("L", &n1, &a[n2], n, info); + cherk_("L", "N", &n1, &n2, &c_b12, a, n, &c_b12, &a[n2], n); + ctrmm_("R", "U", "C", "N", &n1, &n2, &c_b1, &a[n1], n, a, n); + clauum_("U", &n2, &a[n1], n, info); + + } + + } else { + +/* N is odd and TRANSR = 'C' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE, and N is odd */ +/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */ + + clauum_("U", &n1, a, &n1, info); + cherk_("U", "N", &n1, &n2, &c_b12, &a[n1 * n1], &n1, &c_b12, + a, &n1); + ctrmm_("R", "L", "N", "N", &n1, &n2, &c_b1, &a[1], &n1, &a[n1 + * n1], &n1); + clauum_("L", &n2, &a[1], &n1, info); + + } else { + +/* SRPA for UPPER, TRANSPOSE, and N is odd */ +/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */ + + clauum_("U", &n1, &a[n2 * n2], &n2, info); + cherk_("U", "C", &n1, &n2, &c_b12, a, &n2, &c_b12, &a[n2 * n2] + , &n2); + ctrmm_("L", "L", "C", "N", &n2, &n1, &c_b1, &a[n1 * n2], &n2, + a, &n2); + clauum_("L", &n2, &a[n1 * n2], &n2, info); + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + i__1 = *n + 1; + clauum_("L", &k, &a[1], &i__1, info); + i__1 = *n + 1; + i__2 = *n + 1; + cherk_("L", "C", &k, &k, &c_b12, &a[k + 1], &i__1, &c_b12, &a[ + 1], &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + ctrmm_("L", "U", "N", "N", &k, &k, &c_b1, a, &i__1, &a[k + 1], + &i__2); + i__1 = *n + 1; + clauum_("U", &k, a, &i__1, info); + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + i__1 = *n + 1; + clauum_("L", &k, &a[k + 1], &i__1, info); + i__1 = *n + 1; + i__2 = *n + 1; + cherk_("L", "N", &k, &k, &c_b12, a, &i__1, &c_b12, &a[k + 1], + &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + ctrmm_("R", "U", "C", "N", &k, &k, &c_b1, &a[k], &i__1, a, & + i__2); + i__1 = *n + 1; + clauum_("U", &k, &a[k], &i__1, info); + + } + + } else { + +/* N is even and TRANSR = 'C' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + clauum_("U", &k, &a[k], &k, info); + cherk_("U", "N", &k, &k, &c_b12, &a[k * (k + 1)], &k, &c_b12, + &a[k], &k); + ctrmm_("R", "L", "N", "N", &k, &k, &c_b1, a, &k, &a[k * (k + + 1)], &k); + clauum_("L", &k, a, &k, info); + + } else { + +/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + clauum_("U", &k, &a[k * (k + 1)], &k, info); + cherk_("U", "C", &k, &k, &c_b12, a, &k, &c_b12, &a[k * (k + 1) + ], &k); + ctrmm_("L", "L", "C", "N", &k, &k, &c_b1, &a[k * k], &k, a, & + k); + clauum_("L", &k, &a[k * k], &k, info); + + } + + } + + } + + return 0; + +/* End of CPFTRI */ + +} /* cpftri_ */ + diff --git a/lapack-netlib/SRC/cpftrs.c b/lapack-netlib/SRC/cpftrs.c new file mode 100644 index 000000000..ad5bd090b --- /dev/null +++ b/lapack-netlib/SRC/cpftrs.c @@ -0,0 +1,689 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPFTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPFTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* COMPLEX A( 0: * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPFTRS solves a system of linear equations A*X = B with a Hermitian */ +/* > positive definite matrix A using the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H computed by CPFTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal TRANSR of RFP A is stored; */ +/* > = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of RFP A is stored; */ +/* > = 'L': Lower triangle of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( N*(N+1)/2 ); */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > of RFP A = U**H*U or RFP A = L*L**H, as computed by CPFTRF. */ +/* > See note below for more details about RFP A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Standard Packed 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 */ +/* > conjugate-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 */ +/* > conjugate-transpose of the last three columns of AP lower. */ +/* > To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > 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 next consider Standard Packed 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 */ +/* > conjugate-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 */ +/* > conjugate-transpose of the last two columns of AP lower. */ +/* > To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cpftrs_(char *transr, char *uplo, integer *n, integer * + nrhs, complex *a, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + logical normaltransr; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctfsm_(char *, char *, char *, char *, char *, + integer *, integer *, complex *, complex *, complex *, integer *); + logical lower; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "C")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPFTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* start execution: there are two triangular solves */ + + if (lower) { + ctfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b1, a, &b[b_offset], + ldb); + ctfsm_(transr, "L", uplo, "C", "N", n, nrhs, &c_b1, a, &b[b_offset], + ldb); + } else { + ctfsm_(transr, "L", uplo, "C", "N", n, nrhs, &c_b1, a, &b[b_offset], + ldb); + ctfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b1, a, &b[b_offset], + ldb); + } + + return 0; + +/* End of CPFTRS */ + +} /* cpftrs_ */ + diff --git a/lapack-netlib/SRC/cpocon.c b/lapack-netlib/SRC/cpocon.c new file mode 100644 index 000000000..1c9b900aa --- /dev/null +++ b/lapack-netlib/SRC/cpocon.c @@ -0,0 +1,650 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL ANORM, RCOND */ +/* REAL RWORK( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOCON estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex Hermitian positive definite matrix using the */ +/* > Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, as computed by CPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm (or infinity-norm) of the Hermitian matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda, + real *anorm, real *rcond, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + real r__1, r__2; + + /* Local variables */ + integer kase; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + integer ix; + extern integer icamax_(integer *, complex *, integer *); + real scalel; + extern real slamch_(char *); + real scaleu; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real ainvnm; + extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, + integer *, complex *, integer *, complex *, real *, real *, + integer *), csrscl_(integer *, + real *, complex *, integer *); + char normin[1]; + real smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*anorm < 0.f) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm == 0.f) { + return 0; + } + + smlnum = slamch_("Safe minimum"); + +/* Estimate the 1-norm of inv(A). */ + + kase = 0; + *(unsigned char *)normin = 'N'; +L10: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (upper) { + +/* Multiply by inv(U**H). */ + + clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &scalel, &rwork[1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(U). */ + + clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &scaleu, &rwork[1], info); + } else { + +/* Multiply by inv(L). */ + + clatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &scalel, &rwork[1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(L**H). */ + + clatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &scaleu, &rwork[1], info); + } + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + scale = scalel * scaleu; + if (scale != 1.f) { + ix = icamax_(n, &work[1], &c__1); + i__1 = ix; + if (scale < ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& + work[ix]), abs(r__2))) * smlnum || scale == 0.f) { + goto L20; + } + csrscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + +L20: + return 0; + +/* End of CPOCON */ + +} /* cpocon_ */ + diff --git a/lapack-netlib/SRC/cpoequ.c b/lapack-netlib/SRC/cpoequ.c new file mode 100644 index 000000000..e08201d6b --- /dev/null +++ b/lapack-netlib/SRC/cpoequ.c @@ -0,0 +1,603 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOEQU */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOEQU + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* REAL AMAX, SCOND */ +/* REAL S( * ) */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOEQU computes row and column scalings intended to equilibrate a */ +/* > Hermitian positive definite matrix A and reduce its condition number */ +/* > (with respect to the two-norm). S contains the scale factors, */ +/* > S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ +/* > elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ +/* > choice of S puts the condition number of B within a factor N of the */ +/* > smallest possible condition number over all possible diagonal */ +/* > scalings. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The N-by-N Hermitian positive definite matrix whose scaling */ +/* > factors are to be computed. Only the diagonal elements of A */ +/* > are referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > If INFO = 0, S contains the scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* > the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* > large nor too small, it is not worth scaling by S. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element is nonpositive. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpoequ_(integer *n, complex *a, integer *lda, real *s, + real *scond, real *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real smin; + 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --s; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < f2cmax(1,*n)) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOEQU", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *scond = 1.f; + *amax = 0.f; + return 0; + } + +/* Find the minimum and maximum diagonal elements. */ + + i__1 = a_dim1 + 1; + s[1] = a[i__1].r; + smin = s[1]; + *amax = s[1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + s[i__] = a[i__2].r; +/* Computing MIN */ + r__1 = smin, r__2 = s[i__]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = *amax, r__2 = s[i__]; + *amax = f2cmax(r__1,r__2); +/* L10: */ + } + + if (smin <= 0.f) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.f) { + *info = i__; + return 0; + } +/* L20: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 1.f / sqrt(s[i__]); +/* L30: */ + } + +/* Compute SCOND = f2cmin(S(I)) / f2cmax(S(I)) */ + + *scond = sqrt(smin) / sqrt(*amax); + } + return 0; + +/* End of CPOEQU */ + +} /* cpoequ_ */ + diff --git a/lapack-netlib/SRC/cpoequb.c b/lapack-netlib/SRC/cpoequb.c new file mode 100644 index 000000000..41ac2ca88 --- /dev/null +++ b/lapack-netlib/SRC/cpoequb.c @@ -0,0 +1,618 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOEQUB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOEQUB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* REAL AMAX, SCOND */ +/* COMPLEX A( LDA, * ) */ +/* REAL S( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOEQUB computes row and column scalings intended to equilibrate a */ +/* > Hermitian positive definite matrix A and reduce its condition number */ +/* > (with respect to the two-norm). S contains the scale factors, */ +/* > S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ +/* > elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ +/* > choice of S puts the condition number of B within a factor N of the */ +/* > smallest possible condition number over all possible diagonal */ +/* > scalings. */ +/* > */ +/* > This routine differs from CPOEQU by restricting the scaling factors */ +/* > to a power of the radix. Barring over- and underflow, scaling by */ +/* > these factors introduces no additional rounding errors. However, the */ +/* > scaled diagonal entries are no longer approximately 1 but lie */ +/* > between sqrt(radix) and 1/sqrt(radix). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The N-by-N Hermitian positive definite matrix whose scaling */ +/* > factors are to be computed. Only the diagonal elements of A */ +/* > are referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > If INFO = 0, S contains the scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* > the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* > large nor too small, it is not worth scaling by S. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element is nonpositive. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpoequb_(integer *n, complex *a, integer *lda, real *s, + real *scond, real *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + real base, smin; + integer i__; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + +/* Positive definite only performs 1 pass of equilibration. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --s; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < f2cmax(1,*n)) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOEQUB", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + *scond = 1.f; + *amax = 0.f; + return 0; + } + base = slamch_("B"); + tmp = -.5f / log(base); + +/* Find the minimum and maximum diagonal elements. */ + + i__1 = a_dim1 + 1; + s[1] = a[i__1].r; + smin = s[1]; + *amax = s[1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__ + i__ * a_dim1; + s[i__2] = a[i__3].r; +/* Computing MIN */ + r__1 = smin, r__2 = s[i__]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = *amax, r__2 = s[i__]; + *amax = f2cmax(r__1,r__2); +/* L10: */ + } + + if (smin <= 0.f) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.f) { + *info = i__; + return 0; + } +/* L20: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = (integer) (tmp * log(s[i__])); + s[i__] = pow_ri(&base, &i__2); +/* L30: */ + } + +/* Compute SCOND = f2cmin(S(I)) / f2cmax(S(I)). */ + + *scond = sqrt(smin) / sqrt(*amax); + } + + return 0; + +/* End of CPOEQUB */ + +} /* cpoequb_ */ + diff --git a/lapack-netlib/SRC/cporfs.c b/lapack-netlib/SRC/cporfs.c new file mode 100644 index 000000000..0c0711ab9 --- /dev/null +++ b/lapack-netlib/SRC/cporfs.c @@ -0,0 +1,913 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPORFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPORFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, */ +/* LDX, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPORFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is Hermitian positive definite, */ +/* > and provides error bounds and backward error estimates for the */ +/* > solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The Hermitian matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular part */ +/* > of the matrix A, and the strictly lower triangular part of A */ +/* > is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of A contains the lower triangular part of */ +/* > the matrix A, and the strictly upper triangular part of A is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, as computed by CPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by CPOTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cporfs_(char *uplo, integer *n, integer *nrhs, complex * + a, integer *lda, complex *af, integer *ldaf, complex *b, integer *ldb, + complex *x, integer *ldx, real *ferr, real *berr, complex *work, + real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex * + , integer *, complex *, integer *, complex *, complex *, integer * + ); + integer isave[3]; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + integer count; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpotrs_( + char *, integer *, integer *, complex *, integer *, complex *, + integer *, integer *); + real lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ==================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPORFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.f; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + q__1.r = -1.f, q__1.i = 0.f; + chemv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, & + c_b1, &work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[i__] = (r__1 = b[i__3].r, abs(r__1)) + (r__2 = r_imag(&b[ + i__ + j * b_dim1]), abs(r__2)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + k * a_dim1; + rwork[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * xk; + i__4 = i__ + k * a_dim1; + i__5 = i__ + j * x_dim1; + s += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + k * a_dim1]), abs(r__2))) * ((r__3 = x[i__5] + .r, abs(r__3)) + (r__4 = r_imag(&x[i__ + j * + x_dim1]), abs(r__4))); +/* L40: */ + } + i__3 = k + k * a_dim1; + rwork[k] = rwork[k] + (r__1 = a[i__3].r, abs(r__1)) * xk + s; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + i__3 = k + k * a_dim1; + rwork[k] += (r__1 = a[i__3].r, abs(r__1)) * xk; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = i__ + k * a_dim1; + rwork[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * xk; + i__4 = i__ + k * a_dim1; + i__5 = i__ + j * x_dim1; + s += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + k * a_dim1]), abs(r__2))) * ((r__3 = x[i__5] + .r, abs(r__3)) + (r__4 = r_imag(&x[i__ + j * + x_dim1]), abs(r__4))); +/* L60: */ + } + rwork[k] += s; +/* L70: */ + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2))) / rwork[i__]; + s = f2cmax(r__3,r__4); + } else { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(r__3,r__4); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { + +/* Update solution and try again. */ + + cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n, info); + caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + ; + } else { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**H). */ + + cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L120: */ + } + cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * x_dim1; + r__3 = lstres, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[i__ + j * x_dim1]), abs(r__2)); + lstres = f2cmax(r__3,r__4); +/* L130: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of CPORFS */ + +} /* cporfs_ */ + diff --git a/lapack-netlib/SRC/cporfsx.c b/lapack-netlib/SRC/cporfsx.c new file mode 100644 index 000000000..e8dddda2b --- /dev/null +++ b/lapack-netlib/SRC/cporfsx.c @@ -0,0 +1,381 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPOSV computes the solution to system of linear equations A * X = B for PO matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* COMPLEX A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian positive definite matrix and X and B */ +/* > are N-by-NRHS matrices. */ +/* > */ +/* > The Cholesky decomposition is used to factor A as */ +/* > A = U**H* U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is a lower triangular */ +/* > matrix. The factored form of A is then used to solve the system of */ +/* > equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H. */ +/* > \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 COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i of A is not */ +/* > positive definite, so the factorization could not be */ +/* > completed, and the solution has not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOsolve */ + +/* ===================================================================== */ +/* Subroutine */ int cposv_(char *uplo, integer *n, integer *nrhs, complex *a, + integer *lda, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpotrf_( + char *, integer *, complex *, integer *, integer *), + cpotrs_(char *, integer *, integer *, complex *, integer *, + complex *, 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; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the Cholesky factorization A = U**H*U or A = L*L**H. */ + + cpotrf_(uplo, n, &a[a_offset], lda, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + cpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info); + + } + return 0; + +/* End of CPOSV */ + +} /* cposv_ */ + diff --git a/lapack-netlib/SRC/cposvx.c b/lapack-netlib/SRC/cposvx.c new file mode 100644 index 000000000..c56c4fffe --- /dev/null +++ b/lapack-netlib/SRC/cposvx.c @@ -0,0 +1,932 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPOSVX computes the solution to system of linear equations A * X = B for PO matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, */ +/* S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, */ +/* RWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS */ +/* REAL RCOND */ +/* REAL BERR( * ), FERR( * ), RWORK( * ), S( * ) */ +/* COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */ +/* > compute the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian positive definite matrix and X and B */ +/* > are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* > factor the matrix A (after equilibration if FACT = 'E') as */ +/* > A = U**H* U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is a lower triangular */ +/* > matrix. */ +/* > */ +/* > 3. If the leading i-by-i principal minor is not positive definite, */ +/* > then the routine returns with INFO = i. Otherwise, the factored */ +/* > form of A is used to estimate the condition number of the matrix */ +/* > A. If the reciprocal of the condition number is less than machine */ +/* > precision, INFO = N+1 is returned as a warning, but the routine */ +/* > still goes on to solve for X and compute error bounds as */ +/* > described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(S) so that it solves the original system before */ +/* > equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AF contains the factored form of A. */ +/* > If EQUED = 'Y', the matrix A has been equilibrated */ +/* > with scaling factors given by S. A and AF will not */ +/* > be modified. */ +/* > = 'N': The matrix A will be copied to AF and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AF and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A, except if FACT = 'F' and */ +/* > EQUED = 'Y', then A must contain the equilibrated matrix */ +/* > diag(S)*A*diag(S). If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. A is not modified if */ +/* > FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ +/* > */ +/* > On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* > diag(S)*A*diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AF */ +/* > \verbatim */ +/* > AF is COMPLEX array, dimension (LDAF,N) */ +/* > If FACT = 'F', then AF is an input argument and on entry */ +/* > contains the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H, in the same storage */ +/* > format as A. If EQUED .ne. 'N', then AF is the factored form */ +/* > of the equilibrated matrix diag(S)*A*diag(S). */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H of the original */ +/* > matrix A. */ +/* > */ +/* > If FACT = 'E', then AF is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H of the equilibrated */ +/* > matrix A (see the description of A for the form of the */ +/* > equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The scale factors for A; not accessed if EQUED = 'N'. S is */ +/* > an input argument if FACT = 'F'; otherwise, S is an output */ +/* > argument. If FACT = 'F' and EQUED = 'Y', each element of S */ +/* > must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS righthand side matrix B. */ +/* > On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ +/* > B is overwritten by diag(S) * B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ +/* > the original system of equations. Note that if EQUED = 'Y', */ +/* > A and B are modified on exit, and the solution to the */ +/* > equilibrated system is inv(diag(S))*X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The estimate of the reciprocal condition number of the matrix */ +/* > A after equilibration (if done). If RCOND is less than the */ +/* > machine precision (in particular, if RCOND = 0), the matrix */ +/* > is singular to working precision. This condition is */ +/* > indicated by a return code of INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the leading minor of order i of A is */ +/* > not positive definite, so the factorization */ +/* > could not be completed, and the solution has not */ +/* > been computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexPOsolve */ + +/* ===================================================================== */ +/* Subroutine */ int cposvx_(char *fact, char *uplo, integer *n, integer * + nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char * + equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, + real *rcond, real *ferr, real *berr, complex *work, real *rwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2; + complex q__1; + + /* Local variables */ + real amax, smin, smax; + integer i__, j; + extern logical lsame_(char *, char *); + real scond, anorm; + logical equil, rcequ; + extern real clanhe_(char *, char *, integer *, complex *, integer *, real + *); + extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer + *, real *, real *, real *, char *); + extern real slamch_(char *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real bignum; + extern /* Subroutine */ int cpocon_(char *, integer *, complex *, integer + *, real *, real *, complex *, real *, integer *); + integer infequ; + extern /* Subroutine */ int cpoequ_(integer *, complex *, integer *, real + *, real *, real *, integer *), cporfs_(char *, integer *, integer + *, complex *, integer *, complex *, integer *, complex *, integer + *, complex *, integer *, real *, real *, complex *, real *, + integer *), cpotrf_(char *, integer *, complex *, integer + *, integer *), cpotrs_(char *, integer *, integer *, + complex *, integer *, complex *, integer *, integer *); + real smlnum; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = FALSE_; + } else { + rcequ = lsame_(equed, "Y"); + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -9; + } else { + if (rcequ) { + smin = bignum; + smax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = smin, r__2 = s[j]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = smax, r__2 = s[j]; + smax = f2cmax(r__1,r__2); +/* L10: */ + } + if (smin <= 0.f) { + *info = -10; + } else if (*n > 0) { + scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + } else { + scond = 1.f; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -12; + } else if (*ldx < f2cmax(1,*n)) { + *info = -14; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOSVX", &i__1, (ftnlen)6); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + cpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right hand side. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__; + i__5 = i__ + j * b_dim1; + q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L20: */ + } +/* L30: */ + } + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization A = U**H *U or A = L*L**H. */ + + clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + cpotrf_(uplo, n, &af[af_offset], ldaf, info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.f; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]); + +/* Compute the reciprocal of the condition number of A. */ + + cpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1], + info); + +/* Compute the solution matrix X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + cporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[ + b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], & + rwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = i__; + i__5 = i__ + j * x_dim1; + q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L40: */ + } +/* L50: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= scond; +/* L60: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < slamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of CPOSVX */ + +} /* cposvx_ */ + diff --git a/lapack-netlib/SRC/cposvxx.c b/lapack-netlib/SRC/cposvxx.c new file mode 100644 index 000000000..8f329e989 --- /dev/null +++ b/lapack-netlib/SRC/cposvxx.c @@ -0,0 +1,1103 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPOSVXX computes the solution to system of linear equations A * X = B for PO matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOSVXX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, */ +/* S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, */ +/* N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, */ +/* NPARAMS, PARAMS, WORK, RWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, */ +/* $ N_ERR_BNDS */ +/* REAL RCOND, RPVGRW */ +/* COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ +/* REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */ +/* > to compute the solution to a complex system of linear equations */ +/* > A * X = B, where A is an N-by-N Hermitian positive definite matrix */ +/* > and X and B are N-by-NRHS matrices. */ +/* > */ +/* > If requested, both normwise and maximum componentwise error bounds */ +/* > are returned. CPOSVXX will return a solution with a tiny */ +/* > guaranteed error (O(eps) where eps is the working machine */ +/* > precision) unless the matrix is very ill-conditioned, in which */ +/* > case a warning is returned. Relevant condition numbers also are */ +/* > calculated and returned. */ +/* > */ +/* > CPOSVXX accepts user-provided factorizations and equilibration */ +/* > factors; see the definitions of the FACT and EQUED options. */ +/* > Solving with refinement and using a factorization from a previous */ +/* > CPOSVXX call will also produce a solution with either O(eps) */ +/* > errors or warnings, but we cannot make that claim for general */ +/* > user-provided factorizations and equilibration factors if they */ +/* > differ from what CPOSVXX would itself produce. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > */ +/* > diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */ +/* > */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* > factor the matrix A (after equilibration if FACT = 'E') as */ +/* > A = U**T* U, if UPLO = 'U', or */ +/* > A = L * L**T, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is a lower triangular */ +/* > matrix. */ +/* > */ +/* > 3. If the leading i-by-i principal minor is not positive definite, */ +/* > then the routine returns with INFO = i. Otherwise, the factored */ +/* > form of A is used to estimate the condition number of the matrix */ +/* > A (see argument RCOND). If the reciprocal of the condition number */ +/* > is less than machine precision, the routine still goes on to solve */ +/* > for X and compute error bounds as described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ +/* > the routine will use iterative refinement to try to get a small */ +/* > error and error bounds. Refinement calculates the residual to at */ +/* > least twice the working precision. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(S) so that it solves the original system before */ +/* > equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > Some optional parameters are bundled in the PARAMS array. These */ +/* > settings determine how refinement is performed, but often the */ +/* > defaults are acceptable. If the defaults are acceptable, users */ +/* > can pass NPARAMS = 0 which prevents the source code from accessing */ +/* > the PARAMS argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AF contains the factored form of A. */ +/* > If EQUED is not 'N', the matrix A has been */ +/* > equilibrated with scaling factors given by S. */ +/* > A and AF are not modified. */ +/* > = 'N': The matrix A will be copied to AF and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AF and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A, except if FACT = 'F' and EQUED = */ +/* > 'Y', then A must contain the equilibrated matrix */ +/* > diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */ +/* > triangular part of A contains the upper triangular part of the */ +/* > matrix A, and the strictly lower triangular part of A is not */ +/* > referenced. If UPLO = 'L', the leading N-by-N lower triangular */ +/* > part of A contains the lower triangular part of the matrix A, and */ +/* > the strictly upper triangular part of A is not referenced. A is */ +/* > not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */ +/* > 'N' on exit. */ +/* > */ +/* > On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* > diag(S)*A*diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AF */ +/* > \verbatim */ +/* > AF is COMPLEX array, dimension (LDAF,N) */ +/* > If FACT = 'F', then AF is an input argument and on entry */ +/* > contains the triangular factor U or L from the Cholesky */ +/* > factorization A = U**T*U or A = L*L**T, in the same storage */ +/* > format as A. If EQUED .ne. 'N', then AF is the factored */ +/* > form of the equilibrated matrix diag(S)*A*diag(S). */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**T*U or A = L*L**T of the original */ +/* > matrix A. */ +/* > */ +/* > If FACT = 'E', then AF is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**T*U or A = L*L**T of the equilibrated */ +/* > matrix A (see the description of A for the form of the */ +/* > equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'Y': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(S) * A * diag(S). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The row scale factors for A. If EQUED = 'Y', A is multiplied on */ +/* > the left and right by diag(S). S is an input argument if FACT = */ +/* > 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ +/* > = 'Y', each element of S must be positive. If S is output, each */ +/* > element of S is a power of the radix. If S is input, each element */ +/* > of S should be a power of the radix to ensure a reliable solution */ +/* > and error estimates. Scaling by powers of the radix does not cause */ +/* > rounding errors unless the result underflows or overflows. */ +/* > Rounding errors during scaling lead to refining with a matrix that */ +/* > is not equivalent to the input matrix, producing error estimates */ +/* > that may not be reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, */ +/* > if EQUED = 'N', B is not modified; */ +/* > if EQUED = 'Y', B is overwritten by diag(S)*B; */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X to the original */ +/* > system of equations. Note that A and B are modified on exit if */ +/* > EQUED .ne. 'N', and the solution to the equilibrated system is */ +/* > inv(diag(S))*X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RPVGRW */ +/* > \verbatim */ +/* > RPVGRW is REAL */ +/* > Reciprocal pivot growth. On exit, this contains the reciprocal */ +/* > pivot growth factor norm(A)/norm(U). The "f2cmax absolute element" */ +/* > norm is used. If this is much less than 1, then the stability of */ +/* > the LU factorization of the (equilibrated) matrix A could be poor. */ +/* > This also means that the solution X, estimated condition numbers, */ +/* > and error bounds could be unreliable. If factorization fails with */ +/* > 0 for the leading INFO columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > Componentwise relative backward error. This is the */ +/* > componentwise relative backward error of each solution vector X(j) */ +/* > (i.e., the smallest relative change in any element of A or B that */ +/* > makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_ERR_BNDS */ +/* > \verbatim */ +/* > N_ERR_BNDS is INTEGER */ +/* > Number of error bounds to return for each right hand side */ +/* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* > ERR_BNDS_COMP below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NPARAMS */ +/* > \verbatim */ +/* > NPARAMS is INTEGER */ +/* > Specifies the number of parameters set in PARAMS. If <= 0, the */ +/* > PARAMS array is never referenced and default values are used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PARAMS */ +/* > \verbatim */ +/* > PARAMS is REAL array, dimension NPARAMS */ +/* > Specifies algorithm parameters. If an entry is < 0.0, then */ +/* > that entry will be filled with default value used for that */ +/* > parameter. Only positions up to NPARAMS are accessed; defaults */ +/* > are used for higher-numbered parameters. */ +/* > */ +/* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* > refinement or not. */ +/* > Default: 1.0 */ +/* > = 0.0: No refinement is performed, and no error bounds are */ +/* > computed. */ +/* > = 1.0: Use the double-precision refinement algorithm, */ +/* > possibly with doubled-single computations if the */ +/* > compilation environment does not support DOUBLE */ +/* > PRECISION. */ +/* > (other values are reserved for future use) */ +/* > */ +/* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* > computations allowed for refinement. */ +/* > Default: 10 */ +/* > Aggressive: Set to 100 to permit convergence using approximate */ +/* > factorizations or factorizations other than LU. If */ +/* > the factorization uses a technique other than */ +/* > Gaussian elimination, the guarantees in */ +/* > err_bnds_norm and err_bnds_comp may no longer be */ +/* > trustworthy. */ +/* > */ +/* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* > will attempt to find a solution with small componentwise */ +/* > relative error in the double-precision algorithm. Positive */ +/* > is true, 0.0 is false. */ +/* > Default: 1.0 (attempt componentwise convergence) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. The solution to every right-hand side is */ +/* > guaranteed. */ +/* > < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly singular, so */ +/* > the solution and error bounds could not be computed. RCOND = 0 */ +/* > is returned. */ +/* > = N+J: The solution corresponding to the Jth right-hand side is */ +/* > not guaranteed. The solutions corresponding to other right- */ +/* > hand sides K with K > J may not be guaranteed as well, but */ +/* > only the first such right-hand side is reported. If a small */ +/* > componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* > the Jth right-hand side is the first with a normwise error */ +/* > bound that is not guaranteed (the smallest J such */ +/* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* > the Jth right-hand side is the first with either a normwise or */ +/* > componentwise error bound that is not guaranteed (the smallest */ +/* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* > about all of the right-hand sides check ERR_BNDS_NORM or */ +/* > ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexPOsolve */ + +/* ===================================================================== */ +/* Subroutine */ int cposvxx_(char *fact, char *uplo, integer *n, integer * + nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char * + equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, + real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real * + err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real * + params, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + real r__1, r__2; + + /* Local variables */ + real amax, smin, smax; + extern real cla_porpvgrw_(char *, integer *, complex *, integer *, + complex *, integer *, real *); + integer j; + extern logical lsame_(char *, char *); + real scond; + logical equil, rcequ; + extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer + *, real *, real *, real *, char *); + extern real slamch_(char *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real bignum; + integer infequ; + extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer + *, integer *), cpotrs_(char *, integer *, integer *, + complex *, integer *, complex *, integer *, integer *); + real smlnum; + extern /* Subroutine */ int clascl2_(integer *, integer *, real *, + complex *, integer *), cpoequb_(integer *, complex *, integer *, + real *, real *, real *, integer *), cporfsx_(char *, char *, + integer *, integer *, complex *, integer *, complex *, integer *, + real *, complex *, integer *, complex *, integer *, real *, real * + , integer *, real *, real *, integer *, real *, complex *, real *, + integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ================================================================== */ + + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --berr; + --params; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = FALSE_; + } else { + rcequ = lsame_(equed, "Y"); + } + +/* Default is failure. If an input parameter is wrong or */ +/* factorization fails, make everything look horrible. Only the */ +/* pivot growth is set here, the rest is initialized in CPORFSX. */ + + *rpvgrw = 0.f; + +/* Test the input parameters. PARAMS is not tested until CPORFSX. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -9; + } else { + if (rcequ) { + smin = bignum; + smax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = smin, r__2 = s[j]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = smax, r__2 = s[j]; + smax = f2cmax(r__1,r__2); +/* L10: */ + } + if (smin <= 0.f) { + *info = -10; + } else if (*n > 0) { + scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + } else { + scond = 1.f; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -12; + } else if (*ldx < f2cmax(1,*n)) { + *info = -14; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOSVXX", &i__1, (ftnlen)7); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + cpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + clascl2_(n, nrhs, &s[1], &b[b_offset], ldb); + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization of A. */ + + clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + cpotrf_(uplo, n, &af[af_offset], ldaf, info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Pivot in column INFO is exactly 0 */ +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + *rpvgrw = cla_porpvgrw_(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &rwork[1]); + return 0; + } + } + +/* Compute the reciprocal pivot growth factor RPVGRW. */ + + *rpvgrw = cla_porpvgrw_(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf, + &rwork[1]); + +/* Compute the solution matrix X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + cporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, & + s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1], + n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], & + err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[ + 1], &rwork[1], info); + +/* Scale solutions. */ + + if (rcequ) { + clascl2_(n, nrhs, &s[1], &x[x_offset], ldx); + } + + return 0; + +/* End of CPOSVXX */ + +} /* cposvxx_ */ + diff --git a/lapack-netlib/SRC/cpotf2.c b/lapack-netlib/SRC/cpotf2.c new file mode 100644 index 000000000..e5bfb2155 --- /dev/null +++ b/lapack-netlib/SRC/cpotf2.c @@ -0,0 +1,664 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (u +nblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOTF2 computes the Cholesky factorization of a complex Hermitian */ +/* > positive definite matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**H * U , if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* > n by n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization A = U**H *U or A = L*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, the leading minor of order k is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpotf2_(char *uplo, integer *n, complex *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1; + complex q__1, q__2; + + /* Local variables */ + integer j; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + logical upper; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + csscal_(integer *, real *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + extern logical sisnan_(real *); + real ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOTF2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the Cholesky factorization A = U**H *U. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute U(J,J) and test for non-positive-definiteness. */ + + i__2 = j + j * a_dim1; + r__1 = a[i__2].r; + i__3 = j - 1; + cdotc_(&q__2, &i__3, &a[j * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1] + , &c__1); + q__1.r = r__1 - q__2.r, q__1.i = -q__2.i; + ajj = q__1.r; + if (ajj <= 0.f || sisnan_(&ajj)) { + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + goto L30; + } + ajj = sqrt(ajj); + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + +/* Compute elements J+1:N of row J. */ + + if (j < *n) { + i__2 = j - 1; + clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1); + i__2 = j - 1; + i__3 = *n - j; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Transpose", &i__2, &i__3, &q__1, &a[(j + 1) * a_dim1 + + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + ( + j + 1) * a_dim1], lda); + i__2 = j - 1; + clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1); + i__2 = *n - j; + r__1 = 1.f / ajj; + csscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the Cholesky factorization A = L*L**H. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute L(J,J) and test for non-positive-definiteness. */ + + i__2 = j + j * a_dim1; + r__1 = a[i__2].r; + i__3 = j - 1; + cdotc_(&q__2, &i__3, &a[j + a_dim1], lda, &a[j + a_dim1], lda); + q__1.r = r__1 - q__2.r, q__1.i = -q__2.i; + ajj = q__1.r; + if (ajj <= 0.f || sisnan_(&ajj)) { + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + goto L30; + } + ajj = sqrt(ajj); + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + +/* Compute elements J+1:N of column J. */ + + if (j < *n) { + i__2 = j - 1; + clacgv_(&i__2, &a[j + a_dim1], lda); + i__2 = *n - j; + i__3 = j - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &a[j + 1 + a_dim1] + , lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j * + a_dim1], &c__1); + i__2 = j - 1; + clacgv_(&i__2, &a[j + a_dim1], lda); + i__2 = *n - j; + r__1 = 1.f / ajj; + csscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1); + } +/* L20: */ + } + } + goto L40; + +L30: + *info = j; + +L40: + return 0; + +/* End of CPOTF2 */ + +} /* cpotf2_ */ + diff --git a/lapack-netlib/SRC/cpotrf.c b/lapack-netlib/SRC/cpotrf.c new file mode 100644 index 000000000..86b075bff --- /dev/null +++ b/lapack-netlib/SRC/cpotrf.c @@ -0,0 +1,672 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOTRF computes the Cholesky factorization of a complex Hermitian */ +/* > positive definite matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular. */ +/* > */ +/* > This is the block version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpotrf_(char *uplo, integer *n, complex *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + complex q__1; + + /* Local variables */ + integer j; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *), cherk_(char *, + char *, integer *, integer *, real *, complex *, integer *, real * + , complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + integer jb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int cpotrf2_(char *, integer *, complex *, + integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "CPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code. */ + + cpotrf2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code. */ + + if (upper) { + +/* Compute the Cholesky factorization A = U**H *U. */ + + i__1 = *n; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Update and factorize the current diagonal block and test */ +/* for non-positive-definiteness. */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + i__3 = j - 1; + cherk_("Upper", "Conjugate transpose", &jb, &i__3, &c_b14, &a[ + j * a_dim1 + 1], lda, &c_b15, &a[j + j * a_dim1], lda); + cpotrf2_("Upper", &jb, &a[j + j * a_dim1], lda, info); + if (*info != 0) { + goto L30; + } + if (j + jb <= *n) { + +/* Compute the current block row. */ + + i__3 = *n - j - jb + 1; + i__4 = j - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("Conjugate transpose", "No transpose", &jb, &i__3, + &i__4, &q__1, &a[j * a_dim1 + 1], lda, &a[(j + jb) + * a_dim1 + 1], lda, &c_b1, &a[j + (j + jb) * + a_dim1], lda); + i__3 = *n - j - jb + 1; + ctrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", + &jb, &i__3, &c_b1, &a[j + j * a_dim1], lda, &a[j + + (j + jb) * a_dim1], lda); + } +/* L10: */ + } + + } else { + +/* Compute the Cholesky factorization A = L*L**H. */ + + i__2 = *n; + i__1 = nb; + for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Update and factorize the current diagonal block and test */ +/* for non-positive-definiteness. */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + i__3 = j - 1; + cherk_("Lower", "No transpose", &jb, &i__3, &c_b14, &a[j + + a_dim1], lda, &c_b15, &a[j + j * a_dim1], lda); + cpotrf2_("Lower", &jb, &a[j + j * a_dim1], lda, info); + if (*info != 0) { + goto L30; + } + if (j + jb <= *n) { + +/* Compute the current block column. */ + + i__3 = *n - j - jb + 1; + i__4 = j - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__3, &jb, + &i__4, &q__1, &a[j + jb + a_dim1], lda, &a[j + + a_dim1], lda, &c_b1, &a[j + jb + j * a_dim1], lda); + i__3 = *n - j - jb + 1; + ctrsm_("Right", "Lower", "Conjugate transpose", "Non-unit" + , &i__3, &jb, &c_b1, &a[j + j * a_dim1], lda, &a[ + j + jb + j * a_dim1], lda); + } +/* L20: */ + } + } + } + goto L40; + +L30: + *info = *info + j - 1; + +L40: + return 0; + +/* End of CPOTRF */ + +} /* cpotrf_ */ + diff --git a/lapack-netlib/SRC/cpotrf2.c b/lapack-netlib/SRC/cpotrf2.c new file mode 100644 index 000000000..7c40f1838 --- /dev/null +++ b/lapack-netlib/SRC/cpotrf2.c @@ -0,0 +1,639 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOTRF2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOTRF2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOTRF2 computes the Cholesky factorization of a Hermitian */ +/* > positive definite matrix A using the recursive algorithm. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular. */ +/* > */ +/* > This is the recursive version of the algorithm. It divides */ +/* > the matrix into four submatrices: */ +/* > */ +/* > [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 */ +/* > A = [ -----|----- ] with n1 = n/2 */ +/* > [ A21 | A22 ] n2 = n-n1 */ +/* > */ +/* > The subroutine calls itself to factor A11. Update and scale A21 */ +/* > or A12, update A22 then calls itself to factor A22. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpotrf2_(char *uplo, integer *n, complex *a, integer * + lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *, + real *, complex *, integer *, real *, complex *, integer *); + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + integer n1, n2; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern logical sisnan_(real *); + real ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOTRF2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* N=1 case */ + + if (*n == 1) { + +/* Test for non-positive-definiteness */ + + i__1 = a_dim1 + 1; + ajj = a[i__1].r; + if (ajj <= 0.f || sisnan_(&ajj)) { + *info = 1; + return 0; + } + +/* Factor */ + + i__1 = a_dim1 + 1; + r__1 = sqrt(ajj); + a[i__1].r = r__1, a[i__1].i = 0.f; + +/* Use recursive code */ + + } else { + n1 = *n / 2; + n2 = *n - n1; + +/* Factor A11 */ + + cpotrf2_(uplo, &n1, &a[a_dim1 + 1], lda, &iinfo); + if (iinfo != 0) { + *info = iinfo; + return 0; + } + +/* Compute the Cholesky factorization A = U**H*U */ + + if (upper) { + +/* Update and scale A12 */ + + ctrsm_("L", "U", "C", "N", &n1, &n2, &c_b1, &a[a_dim1 + 1], lda, & + a[(n1 + 1) * a_dim1 + 1], lda); + +/* Update and factor A22 */ + + cherk_(uplo, "C", &n2, &n1, &c_b11, &a[(n1 + 1) * a_dim1 + 1], + lda, &c_b12, &a[n1 + 1 + (n1 + 1) * a_dim1], lda); + + cpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo); + + if (iinfo != 0) { + *info = iinfo + n1; + return 0; + } + +/* Compute the Cholesky factorization A = L*L**H */ + + } else { + +/* Update and scale A21 */ + + ctrsm_("R", "L", "C", "N", &n2, &n1, &c_b1, &a[a_dim1 + 1], lda, & + a[n1 + 1 + a_dim1], lda); + +/* Update and factor A22 */ + + cherk_(uplo, "N", &n2, &n1, &c_b11, &a[n1 + 1 + a_dim1], lda, & + c_b12, &a[n1 + 1 + (n1 + 1) * a_dim1], lda); + + cpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo); + + if (iinfo != 0) { + *info = iinfo + n1; + return 0; + } + + } + } + return 0; + +/* End of CPOTRF2 */ + +} /* cpotrf2_ */ + diff --git a/lapack-netlib/SRC/cpotri.c b/lapack-netlib/SRC/cpotri.c new file mode 100644 index 000000000..31b2f210e --- /dev/null +++ b/lapack-netlib/SRC/cpotri.c @@ -0,0 +1,550 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOTRI computes the inverse of a complex Hermitian positive definite */ +/* > matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */ +/* > computed by CPOTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H, as computed by */ +/* > CPOTRF. */ +/* > On exit, the upper or lower triangle of the (Hermitian) */ +/* > inverse of A, overwriting the input factor U or L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the (i,i) element of the factor U or L is */ +/* > zero, and the inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpotri_(char *uplo, integer *n, complex *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), clauum_( + char *, integer *, complex *, integer *, integer *), + ctrtri_(char *, char *, integer *, complex *, integer *, integer * + ); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Invert the triangular Cholesky factor U or L. */ + + ctrtri_(uplo, "Non-unit", n, &a[a_offset], lda, info); + if (*info > 0) { + return 0; + } + +/* Form inv(U) * inv(U)**H or inv(L)**H * inv(L). */ + + clauum_(uplo, n, &a[a_offset], lda, info); + + return 0; + +/* End of CPOTRI */ + +} /* cpotri_ */ + diff --git a/lapack-netlib/SRC/cpotrs.c b/lapack-netlib/SRC/cpotrs.c new file mode 100644 index 000000000..f9a12e4f0 --- /dev/null +++ b/lapack-netlib/SRC/cpotrs.c @@ -0,0 +1,595 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPOTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPOTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* COMPLEX A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPOTRS solves a system of linear equations A*X = B with a Hermitian */ +/* > positive definite matrix A using the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H computed by CPOTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, as computed by CPOTRF. */ +/* > \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 COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPOcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpotrs_(char *uplo, integer *n, integer *nrhs, complex * + a, integer *lda, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPOTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B where A = U**H *U. */ + +/* Solve U**H *X = B, overwriting B with X. */ + + ctrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", n, nrhs, & + c_b1, &a[a_offset], lda, &b[b_offset], ldb); + +/* Solve U*X = B, overwriting B with X. */ + + ctrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, & + a[a_offset], lda, &b[b_offset], ldb); + } else { + +/* Solve A*X = B where A = L*L**H. */ + +/* Solve L*X = B, overwriting B with X. */ + + ctrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b1, & + a[a_offset], lda, &b[b_offset], ldb); + +/* Solve L**H *X = B, overwriting B with X. */ + + ctrsm_("Left", "Lower", "Conjugate transpose", "Non-unit", n, nrhs, & + c_b1, &a[a_offset], lda, &b[b_offset], ldb); + } + + return 0; + +/* End of CPOTRS */ + +} /* cpotrs_ */ + diff --git a/lapack-netlib/SRC/cppcon.c b/lapack-netlib/SRC/cppcon.c new file mode 100644 index 000000000..522868010 --- /dev/null +++ b/lapack-netlib/SRC/cppcon.c @@ -0,0 +1,644 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPPCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* REAL ANORM, RCOND */ +/* REAL RWORK( * ) */ +/* COMPLEX AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPCON estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex Hermitian positive definite packed matrix using */ +/* > the Cholesky factorization A = U**H*U or A = L*L**H computed by */ +/* > CPPTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, packed columnwise in a linear */ +/* > array. The j-th column of U or L is stored in the array AP */ +/* > as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm (or infinity-norm) of the Hermitian matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cppcon_(char *uplo, integer *n, complex *ap, real *anorm, + real *rcond, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + integer kase; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + integer ix; + extern integer icamax_(integer *, complex *, integer *); + real scalel; + extern real slamch_(char *); + real scaleu; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), clatps_( + char *, char *, char *, char *, integer *, complex *, complex *, + real *, real *, integer *); + real ainvnm; + extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer + *); + char normin[1]; + real smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --rwork; + --work; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*anorm < 0.f) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm == 0.f) { + return 0; + } + + smlnum = slamch_("Safe minimum"); + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; + *(unsigned char *)normin = 'N'; +L10: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (upper) { + +/* Multiply by inv(U**H). */ + + clatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, & + ap[1], &work[1], &scalel, &rwork[1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(U). */ + + clatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], & + work[1], &scaleu, &rwork[1], info); + } else { + +/* Multiply by inv(L). */ + + clatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], & + work[1], &scalel, &rwork[1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(L**H). */ + + clatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, & + ap[1], &work[1], &scaleu, &rwork[1], info); + } + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + scale = scalel * scaleu; + if (scale != 1.f) { + ix = icamax_(n, &work[1], &c__1); + i__1 = ix; + if (scale < ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& + work[ix]), abs(r__2))) * smlnum || scale == 0.f) { + goto L20; + } + csrscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + +L20: + return 0; + +/* End of CPPCON */ + +} /* cppcon_ */ + diff --git a/lapack-netlib/SRC/cppequ.c b/lapack-netlib/SRC/cppequ.c new file mode 100644 index 000000000..fcda76576 --- /dev/null +++ b/lapack-netlib/SRC/cppequ.c @@ -0,0 +1,637 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPPEQU */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPEQU + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* REAL AMAX, SCOND */ +/* REAL S( * ) */ +/* COMPLEX AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPEQU computes row and column scalings intended to equilibrate a */ +/* > Hermitian positive definite matrix A in packed storage and reduce */ +/* > its condition number (with respect to the two-norm). S contains the */ +/* > scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */ +/* > B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */ +/* > This choice of S puts the condition number of B within a factor N of */ +/* > the smallest possible condition number over all possible diagonal */ +/* > scalings. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the Hermitian matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > If INFO = 0, S contains the scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* > the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* > large nor too small, it is not worth scaling by S. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element is nonpositive. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cppequ_(char *uplo, integer *n, complex *ap, real *s, + real *scond, real *amax, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real smin; + integer i__; + extern logical lsame_(char *, char *); + logical upper; + integer jj; + 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 */ + --s; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPEQU", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *scond = 1.f; + *amax = 0.f; + return 0; + } + +/* Initialize SMIN and AMAX. */ + + s[1] = ap[1].r; + smin = s[1]; + *amax = s[1]; + + if (upper) { + +/* UPLO = 'U': Upper triangle of A is stored. */ +/* Find the minimum and maximum diagonal elements. */ + + jj = 1; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + jj += i__; + i__2 = jj; + s[i__] = ap[i__2].r; +/* Computing MIN */ + r__1 = smin, r__2 = s[i__]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = *amax, r__2 = s[i__]; + *amax = f2cmax(r__1,r__2); +/* L10: */ + } + + } else { + +/* UPLO = 'L': Lower triangle of A is stored. */ +/* Find the minimum and maximum diagonal elements. */ + + jj = 1; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + jj = jj + *n - i__ + 2; + i__2 = jj; + s[i__] = ap[i__2].r; +/* Computing MIN */ + r__1 = smin, r__2 = s[i__]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = *amax, r__2 = s[i__]; + *amax = f2cmax(r__1,r__2); +/* L20: */ + } + } + + if (smin <= 0.f) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.f) { + *info = i__; + return 0; + } +/* L30: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 1.f / sqrt(s[i__]); +/* L40: */ + } + +/* Compute SCOND = f2cmin(S(I)) / f2cmax(S(I)) */ + + *scond = sqrt(smin) / sqrt(*amax); + } + return 0; + +/* End of CPPEQU */ + +} /* cppequ_ */ + diff --git a/lapack-netlib/SRC/cpprfs.c b/lapack-netlib/SRC/cpprfs.c new file mode 100644 index 000000000..e620ac4b1 --- /dev/null +++ b/lapack-netlib/SRC/cpprfs.c @@ -0,0 +1,897 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPPRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, */ +/* BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is Hermitian positive definite */ +/* > and packed, and provides error bounds and backward error estimates */ +/* > for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the Hermitian matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFP */ +/* > \verbatim */ +/* > AFP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF, */ +/* > packed columnwise in a linear array in the same format as A */ +/* > (see AP). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by CPPTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpprfs_(char *uplo, integer *n, integer *nrhs, complex * + ap, complex *afp, complex *b, integer *ldb, complex *x, integer *ldx, + real *ferr, real *berr, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), chpmv_(char *, integer *, complex *, + complex *, complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, + complex *, integer *); + integer count; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + integer ik, kk; + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpptrs_( + char *, integer *, integer *, complex *, complex *, integer *, + integer *); + real lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ==================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldx < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.f; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + q__1.r = -1.f, q__1.i = 0.f; + chpmv_(uplo, n, &q__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, & + work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[i__] = (r__1 = b[i__3].r, abs(r__1)) + (r__2 = r_imag(&b[ + i__ + j * b_dim1]), abs(r__2)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + kk = 1; + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + ik = kk; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ik; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[ik]), abs(r__2))) * xk; + i__4 = ik; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = r_imag(&ap[ + ik]), abs(r__2))) * ((r__3 = x[i__5].r, abs(r__3)) + + (r__4 = r_imag(&x[i__ + j * x_dim1]), abs(r__4) + )); + ++ik; +/* L40: */ + } + i__3 = kk + k - 1; + rwork[k] = rwork[k] + (r__1 = ap[i__3].r, abs(r__1)) * xk + s; + kk += k; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + i__3 = kk; + rwork[k] += (r__1 = ap[i__3].r, abs(r__1)) * xk; + ik = kk + 1; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = ik; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[ik]), abs(r__2))) * xk; + i__4 = ik; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = r_imag(&ap[ + ik]), abs(r__2))) * ((r__3 = x[i__5].r, abs(r__3)) + + (r__4 = r_imag(&x[i__ + j * x_dim1]), abs(r__4) + )); + ++ik; +/* L60: */ + } + rwork[k] += s; + kk += *n - k + 1; +/* L70: */ + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2))) / rwork[i__]; + s = f2cmax(r__3,r__4); + } else { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(r__3,r__4); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { + +/* Update solution and try again. */ + + cpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info); + caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + ; + } else { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**H). */ + + cpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info) + ; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L120: */ + } + cpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info) + ; + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * x_dim1; + r__3 = lstres, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[i__ + j * x_dim1]), abs(r__2)); + lstres = f2cmax(r__3,r__4); +/* L130: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of CPPRFS */ + +} /* cpprfs_ */ + diff --git a/lapack-netlib/SRC/cppsv.c b/lapack-netlib/SRC/cppsv.c new file mode 100644 index 000000000..60e7c44f1 --- /dev/null +++ b/lapack-netlib/SRC/cppsv.c @@ -0,0 +1,594 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPPSV computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* COMPLEX AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian positive definite matrix stored in */ +/* > packed format and X and B are N-by-NRHS matrices. */ +/* > */ +/* > The Cholesky decomposition is used to factor A as */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is a lower triangular */ +/* > matrix. The factored form of A is then used to solve the system of */ +/* > equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H, in the same storage */ +/* > format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i of A is not */ +/* > positive definite, so the factorization could not be */ +/* > completed, and the solution has not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the Hermitian matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = conjg(aji)) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cppsv_(char *uplo, integer *n, integer *nrhs, complex * + ap, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpptrf_( + char *, integer *, complex *, integer *), cpptrs_(char *, + integer *, integer *, complex *, complex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the Cholesky factorization A = U**H *U or A = L*L**H. */ + + cpptrf_(uplo, n, &ap[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + cpptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info); + + } + return 0; + +/* End of CPPSV */ + +} /* cppsv_ */ + diff --git a/lapack-netlib/SRC/cppsvx.c b/lapack-netlib/SRC/cppsvx.c new file mode 100644 index 000000000..48538252e --- /dev/null +++ b/lapack-netlib/SRC/cppsvx.c @@ -0,0 +1,931 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, */ +/* X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* REAL RCOND */ +/* REAL BERR( * ), FERR( * ), RWORK( * ), S( * ) */ +/* COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */ +/* > compute the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian positive definite matrix stored in */ +/* > packed format and X and B are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* > factor the matrix A (after equilibration if FACT = 'E') as */ +/* > A = U**H * U , if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix, L is a lower triangular */ +/* > matrix, and **H indicates conjugate transpose. */ +/* > */ +/* > 3. If the leading i-by-i principal minor is not positive definite, */ +/* > then the routine returns with INFO = i. Otherwise, the factored */ +/* > form of A is used to estimate the condition number of the matrix */ +/* > A. If the reciprocal of the condition number is less than machine */ +/* > precision, INFO = N+1 is returned as a warning, but the routine */ +/* > still goes on to solve for X and compute error bounds as */ +/* > described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(S) so that it solves the original system before */ +/* > equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AFP contains the factored form of A. */ +/* > If EQUED = 'Y', the matrix A has been equilibrated */ +/* > with scaling factors given by S. AP and AFP will not */ +/* > be modified. */ +/* > = 'N': The matrix A will be copied to AFP and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AFP and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array, except if FACT = 'F' */ +/* > and EQUED = 'Y', then A must contain the equilibrated matrix */ +/* > diag(S)*A*diag(S). The j-th column of A is stored in the */ +/* > array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. A is not modified if */ +/* > FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ +/* > */ +/* > On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* > diag(S)*A*diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFP */ +/* > \verbatim */ +/* > AFP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > If FACT = 'F', then AFP is an input argument and on entry */ +/* > contains the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H, in the same storage */ +/* > format as A. If EQUED .ne. 'N', then AFP is the factored */ +/* > form of the equilibrated matrix A. */ +/* > */ +/* > If FACT = 'N', then AFP is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H * U or A = L * L**H of the original */ +/* > matrix A. */ +/* > */ +/* > If FACT = 'E', then AFP is an output argument and on exit */ +/* > returns the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H of the equilibrated */ +/* > matrix A (see the description of AP for the form of the */ +/* > equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The scale factors for A; not accessed if EQUED = 'N'. S is */ +/* > an input argument if FACT = 'F'; otherwise, S is an output */ +/* > argument. If FACT = 'F' and EQUED = 'Y', each element of S */ +/* > must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ +/* > B is overwritten by diag(S) * B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ +/* > the original system of equations. Note that if EQUED = 'Y', */ +/* > A and B are modified on exit, and the solution to the */ +/* > equilibrated system is inv(diag(S))*X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The estimate of the reciprocal condition number of the matrix */ +/* > A after equilibration (if done). If RCOND is less than the */ +/* > machine precision (in particular, if RCOND = 0), the matrix */ +/* > is singular to working precision. This condition is */ +/* > indicated by a return code of INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the leading minor of order i of A is */ +/* > not positive definite, so the factorization */ +/* > could not be completed, and the solution has not */ +/* > been computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the Hermitian matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = conjg(aji)) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cppsvx_(char *fact, char *uplo, integer *n, integer * + nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b, + integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real + *berr, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2; + complex q__1; + + /* Local variables */ + real amax, smin, smax; + integer i__, j; + extern logical lsame_(char *, char *); + real scond, anorm; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + logical equil, rcequ; + extern real clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *); + extern /* Subroutine */ int claqhp_(char *, integer *, complex *, real *, + real *, real *, char *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real bignum; + extern /* Subroutine */ int cppcon_(char *, integer *, complex *, real *, + real *, complex *, real *, integer *); + integer infequ; + extern /* Subroutine */ int cppequ_(char *, integer *, complex *, real *, + real *, real *, integer *), cpprfs_(char *, integer *, + integer *, complex *, complex *, complex *, integer *, complex *, + integer *, real *, real *, complex *, real *, integer *), + cpptrf_(char *, integer *, complex *, integer *); + real smlnum; + extern /* Subroutine */ int cpptrs_(char *, integer *, integer *, complex + *, complex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --ap; + --afp; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = FALSE_; + } else { + rcequ = lsame_(equed, "Y"); + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -7; + } else { + if (rcequ) { + smin = bignum; + smax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = smin, r__2 = s[j]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = smax, r__2 = s[j]; + smax = f2cmax(r__1,r__2); +/* L10: */ + } + if (smin <= 0.f) { + *info = -8; + } else if (*n > 0) { + scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + } else { + scond = 1.f; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldx < f2cmax(1,*n)) { + *info = -12; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPSVX", &i__1, (ftnlen)6); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + cppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + claqhp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__; + i__5 = i__ + j * b_dim1; + q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L20: */ + } +/* L30: */ + } + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization A = U**H * U or A = L * L**H. */ + + i__1 = *n * (*n + 1) / 2; + ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); + cpptrf_(uplo, n, &afp[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.f; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]); + +/* Compute the reciprocal of the condition number of A. */ + + cppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &rwork[1], info); + +/* Compute the solution matrix X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + cpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + cpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset], + ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = i__; + i__5 = i__ + j * x_dim1; + q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L40: */ + } +/* L50: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= scond; +/* L60: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < slamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of CPPSVX */ + +} /* cppsvx_ */ + diff --git a/lapack-netlib/SRC/cpptrf.c b/lapack-netlib/SRC/cpptrf.c new file mode 100644 index 000000000..7036a45da --- /dev/null +++ b/lapack-netlib/SRC/cpptrf.c @@ -0,0 +1,653 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPPTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPTRF( UPLO, N, AP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* COMPLEX AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPTRF computes the Cholesky factorization of a complex Hermitian */ +/* > positive definite matrix A stored in packed format. */ +/* > */ +/* > The factorization has the form */ +/* > A = U**H * U, if UPLO = 'U', or */ +/* > A = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > */ +/* > On exit, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**H*U or A = L*L**H, in the same */ +/* > storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i is not */ +/* > positive definite, and the factorization could not be */ +/* > completed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the Hermitian matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = conjg(aji)) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cpptrf_(char *uplo, integer *n, complex *ap, integer * + info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1; + complex q__1, q__2; + + /* Local variables */ + extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *, + integer *, complex *); + integer j; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, + complex *, complex *, integer *); + integer jc, jj; + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + real ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the Cholesky factorization A = U**H * U. */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + +/* Compute elements 1:J-1 of column J. */ + + if (j > 1) { + i__2 = j - 1; + ctpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[ + 1], &ap[jc], &c__1); + } + +/* Compute U(J,J) and test for non-positive-definiteness. */ + + i__2 = jj; + r__1 = ap[i__2].r; + i__3 = j - 1; + cdotc_(&q__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1); + q__1.r = r__1 - q__2.r, q__1.i = -q__2.i; + ajj = q__1.r; + if (ajj <= 0.f) { + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.f; + goto L30; + } + i__2 = jj; + r__1 = sqrt(ajj); + ap[i__2].r = r__1, ap[i__2].i = 0.f; +/* L10: */ + } + } else { + +/* Compute the Cholesky factorization A = L * L**H. */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute L(J,J) and test for non-positive-definiteness. */ + + i__2 = jj; + ajj = ap[i__2].r; + if (ajj <= 0.f) { + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.f; + goto L30; + } + ajj = sqrt(ajj); + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.f; + +/* Compute elements J+1:N of column J and update the trailing */ +/* submatrix. */ + + if (j < *n) { + i__2 = *n - j; + r__1 = 1.f / ajj; + csscal_(&i__2, &r__1, &ap[jj + 1], &c__1); + i__2 = *n - j; + chpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n + - j + 1]); + jj = jj + *n - j + 1; + } +/* L20: */ + } + } + goto L40; + +L30: + *info = j; + +L40: + return 0; + +/* End of CPPTRF */ + +} /* cpptrf_ */ + diff --git a/lapack-netlib/SRC/cpptri.c b/lapack-netlib/SRC/cpptri.c new file mode 100644 index 000000000..3e7869dfd --- /dev/null +++ b/lapack-netlib/SRC/cpptri.c @@ -0,0 +1,599 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPTRI( UPLO, N, AP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* COMPLEX AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPTRI computes the inverse of a complex Hermitian positive definite */ +/* > matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */ +/* > computed by CPPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular factor is stored in AP; */ +/* > = 'L': Lower triangular factor is stored in AP. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > On entry, the triangular factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H, packed columnwise as */ +/* > a linear array. The j-th column of U or L is stored in the */ +/* > array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the upper or lower triangle of the (Hermitian) */ +/* > inverse of A, overwriting the input factor U or L. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the (i,i) element of the factor U or L is */ +/* > zero, and the inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpptri_(char *uplo, integer *n, complex *ap, integer * + info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1; + complex q__1; + + /* Local variables */ + extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *, + integer *, complex *); + integer j; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *, + complex *, complex *, integer *); + logical upper; + integer jc, jj; + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen), ctptri_(char *, char *, + integer *, complex *, integer *); + real ajj; + integer jjn; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Invert the triangular Cholesky factor U or L. */ + + ctptri_(uplo, "Non-unit", n, &ap[1], info); + if (*info > 0) { + return 0; + } + if (upper) { + +/* Compute the product inv(U) * inv(U)**H. */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + if (j > 1) { + i__2 = j - 1; + chpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]); + } + i__2 = jj; + ajj = ap[i__2].r; + csscal_(&j, &ajj, &ap[jc], &c__1); +/* L10: */ + } + + } else { + +/* Compute the product inv(L)**H * inv(L). */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jjn = jj + *n - j + 1; + i__2 = jj; + i__3 = *n - j + 1; + cdotc_(&q__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1); + r__1 = q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + if (j < *n) { + i__2 = *n - j; + ctpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[ + jjn], &ap[jj + 1], &c__1); + } + jj = jjn; +/* L20: */ + } + } + + return 0; + +/* End of CPPTRI */ + +} /* cpptri_ */ + diff --git a/lapack-netlib/SRC/cpptrs.c b/lapack-netlib/SRC/cpptrs.c new file mode 100644 index 000000000..92a209281 --- /dev/null +++ b/lapack-netlib/SRC/cpptrs.c @@ -0,0 +1,599 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* COMPLEX AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPPTRS solves a system of linear equations A*X = B with a Hermitian */ +/* > positive definite matrix A in packed storage using the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H computed by CPPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, packed columnwise in a linear */ +/* > array. The j-th column of U or L is stored in the array AP */ +/* > as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex * + ap, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, + complex *, complex *, integer *), xerbla_( + char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPPTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B where A = U**H * U. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U**H *X = B, overwriting B with X. */ + + ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &ap[1], &b[ + i__ * b_dim1 + 1], &c__1); + +/* Solve U*X = B, overwriting B with X. */ + + ctpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Solve A*X = B where A = L * L**H. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve L*Y = B, overwriting B with X. */ + + ctpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); + +/* Solve L**H *X = Y, overwriting B with X. */ + + ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &ap[1], &b[ + i__ * b_dim1 + 1], &c__1); +/* L20: */ + } + } + + return 0; + +/* End of CPPTRS */ + +} /* cpptrs_ */ + diff --git a/lapack-netlib/SRC/cpstf2.c b/lapack-netlib/SRC/cpstf2.c new file mode 100644 index 000000000..fc02be7af --- /dev/null +++ b/lapack-netlib/SRC/cpstf2.c @@ -0,0 +1,878 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPSTF2 computes the Cholesky factorization with complete pivoting of complex Hermitian positive + semidefinite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPSTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) */ + +/* REAL TOL */ +/* INTEGER INFO, LDA, N, RANK */ +/* CHARACTER UPLO */ +/* COMPLEX A( LDA, * ) */ +/* REAL WORK( 2*N ) */ +/* INTEGER PIV( N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPSTF2 computes the Cholesky factorization with complete */ +/* > pivoting of a complex Hermitian positive semidefinite matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > P**T * A * P = U**H * U , if UPLO = 'U', */ +/* > P**T * A * P = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular, and */ +/* > P is stored as vector PIV. */ +/* > */ +/* > This algorithm does not attempt to check that A is positive */ +/* > semidefinite. This version of the algorithm calls level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n by n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization as above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PIV */ +/* > \verbatim */ +/* > PIV is INTEGER array, dimension (N) */ +/* > PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of A given by the number of steps the algorithm */ +/* > completed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOL */ +/* > \verbatim */ +/* > TOL is REAL */ +/* > User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */ +/* > will be used. The algorithm terminates at the (K-1)st step */ +/* > if the pivot <= TOL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > Work space. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > < 0: If INFO = -K, the K-th argument had an illegal value, */ +/* > = 0: algorithm completed successfully, and */ +/* > > 0: the matrix A is either rank deficient with computed rank */ +/* > as returned in RANK, or is not positive semidefinite. See */ +/* > Section 7 of LAPACK Working Note #161 for further */ +/* > information. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpstf2_(char *uplo, integer *n, complex *a, integer *lda, + integer *piv, integer *rank, real *tol, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1; + complex q__1, q__2; + + /* Local variables */ + + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + complex ctemp; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer itemp; + real stemp; + logical upper; + real sstop; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + extern logical sisnan_(real *); + real ajj; + integer pvt; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + --work; + --piv; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPSTF2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Initialize PIV */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + piv[i__] = i__; +/* L100: */ + } + +/* Compute stopping value */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + work[i__] = a[i__2].r; +/* L110: */ + } + pvt = mymaxloc_(&work[1], &c__1, n, &c__1); + i__1 = pvt + pvt * a_dim1; + ajj = a[i__1].r; + if (ajj <= 0.f || sisnan_(&ajj)) { + *rank = 0; + *info = 1; + goto L200; + } + +/* Compute stopping value if not supplied */ + + if (*tol < 0.f) { + sstop = *n * slamch_("Epsilon") * ajj; + } else { + sstop = *tol; + } + +/* Set first half of WORK to zero, holds dot products */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L120: */ + } + + if (upper) { + +/* Compute the Cholesky factorization P**T * A * P = U**H * U */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + + if (j > 1) { + r_cnjg(&q__2, &a[j - 1 + i__ * a_dim1]); + i__3 = j - 1 + i__ * a_dim1; + q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i = + q__2.r * a[i__3].i + q__2.i * a[i__3].r; + work[i__] += q__1.r; + } + i__3 = i__ + i__ * a_dim1; + work[*n + i__] = a[i__3].r - work[i__]; + +/* L130: */ + } + + if (j > 1) { + i__2 = *n + j; + i__3 = *n << 1; + itemp = mymaxloc_(&work[1], &i__2, &i__3, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= sstop || sisnan_(&ajj)) { + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + goto L190; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + i__2 = pvt + pvt * a_dim1; + i__3 = j + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = j - 1; + cswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1], + &c__1); + if (pvt < *n) { + i__2 = *n - pvt; + cswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + ( + pvt + 1) * a_dim1], lda); + } + i__2 = pvt - 1; + for (i__ = j + 1; i__ <= i__2; ++i__) { + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &a[i__ + pvt * a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = i__ + pvt * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L140: */ + } + i__2 = j + pvt * a_dim1; + r_cnjg(&q__1, &a[j + pvt * a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + +/* Swap dot products and PIV */ + + stemp = work[j]; + work[j] = work[pvt]; + work[pvt] = stemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + +/* Compute elements J+1:N of row J */ + + if (j < *n) { + i__2 = j - 1; + clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1); + i__2 = j - 1; + i__3 = *n - j; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Trans", &i__2, &i__3, &q__1, &a[(j + 1) * a_dim1 + 1], + lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (j + 1) + * a_dim1], lda); + i__2 = j - 1; + clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1); + i__2 = *n - j; + r__1 = 1.f / ajj; + csscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda); + } + +/* L150: */ + } + + } else { + +/* Compute the Cholesky factorization P**T * A * P = L * L**H */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + + if (j > 1) { + r_cnjg(&q__2, &a[i__ + (j - 1) * a_dim1]); + i__3 = i__ + (j - 1) * a_dim1; + q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i = + q__2.r * a[i__3].i + q__2.i * a[i__3].r; + work[i__] += q__1.r; + } + i__3 = i__ + i__ * a_dim1; + work[*n + i__] = a[i__3].r - work[i__]; + +/* L160: */ + } + + if (j > 1) { + i__2 = *n + j; + i__3 = *n << 1; + itemp = mymaxloc_(&work[1], &i__2, &i__3, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= sstop || sisnan_(&ajj)) { + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + goto L190; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + i__2 = pvt + pvt * a_dim1; + i__3 = j + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = j - 1; + cswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda); + if (pvt < *n) { + i__2 = *n - pvt; + cswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1 + + pvt * a_dim1], &c__1); + } + i__2 = pvt - 1; + for (i__ = j + 1; i__ <= i__2; ++i__) { + r_cnjg(&q__1, &a[i__ + j * a_dim1]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__3 = i__ + j * a_dim1; + r_cnjg(&q__1, &a[pvt + i__ * a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = pvt + i__ * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L170: */ + } + i__2 = pvt + j * a_dim1; + r_cnjg(&q__1, &a[pvt + j * a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + +/* Swap dot products and PIV */ + + stemp = work[j]; + work[j] = work[pvt]; + work[pvt] = stemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + i__2 = j + j * a_dim1; + a[i__2].r = ajj, a[i__2].i = 0.f; + +/* Compute elements J+1:N of column J */ + + if (j < *n) { + i__2 = j - 1; + clacgv_(&i__2, &a[j + a_dim1], lda); + i__2 = *n - j; + i__3 = j - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No Trans", &i__2, &i__3, &q__1, &a[j + 1 + a_dim1], + lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j * + a_dim1], &c__1); + i__2 = j - 1; + clacgv_(&i__2, &a[j + a_dim1], lda); + i__2 = *n - j; + r__1 = 1.f / ajj; + csscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1); + } + +/* L180: */ + } + + } + +/* Ran to completion, A has full rank */ + + *rank = *n; + + goto L200; +L190: + +/* Rank is number of steps completed. Set INFO = 1 to signal */ +/* that the factorization cannot be used to solve a system. */ + + *rank = j - 1; + *info = 1; + +L200: + return 0; + +/* End of CPSTF2 */ + +} /* cpstf2_ */ + diff --git a/lapack-netlib/SRC/cpstrf.c b/lapack-netlib/SRC/cpstrf.c new file mode 100644 index 000000000..72ea45887 --- /dev/null +++ b/lapack-netlib/SRC/cpstrf.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 CPSTRF computes the Cholesky factorization with complete pivoting of complex Hermitian positive + semidefinite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPSTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) */ + +/* REAL TOL */ +/* INTEGER INFO, LDA, N, RANK */ +/* CHARACTER UPLO */ +/* COMPLEX A( LDA, * ) */ +/* REAL WORK( 2*N ) */ +/* INTEGER PIV( N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPSTRF computes the Cholesky factorization with complete */ +/* > pivoting of a complex Hermitian positive semidefinite matrix A. */ +/* > */ +/* > The factorization has the form */ +/* > P**T * A * P = U**H * U , if UPLO = 'U', */ +/* > P**T * A * P = L * L**H, if UPLO = 'L', */ +/* > where U is an upper triangular matrix and L is lower triangular, and */ +/* > P is stored as vector PIV. */ +/* > */ +/* > This algorithm does not attempt to check that A is positive */ +/* > semidefinite. This version of the algorithm calls level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n by n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* > factorization as above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PIV */ +/* > \verbatim */ +/* > PIV is INTEGER array, dimension (N) */ +/* > PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of A given by the number of steps the algorithm */ +/* > completed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOL */ +/* > \verbatim */ +/* > TOL is REAL */ +/* > User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */ +/* > will be used. The algorithm terminates at the (K-1)st step */ +/* > if the pivot <= TOL. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > Work space. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > < 0: If INFO = -K, the K-th argument had an illegal value, */ +/* > = 0: algorithm completed successfully, and */ +/* > > 0: the matrix A is either rank deficient with computed rank */ +/* > as returned in RANK, or is not positive semidefinite. See */ +/* > Section 7 of LAPACK Working Note #161 for further */ +/* > information. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpstrf_(char *uplo, integer *n, complex *a, integer *lda, + integer *piv, integer *rank, real *tol, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + real r__1; + complex q__1, q__2; + + /* Local variables */ + + integer i__, j, k; + extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *, + real *, complex *, integer *, real *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + complex ctemp; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer itemp; + real stemp; + logical upper; + real sstop; + extern /* Subroutine */ int cpstf2_(char *, integer *, complex *, integer + *, integer *, integer *, real *, real *, integer *); + integer jb, nb; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern logical sisnan_(real *); + real ajj; + integer pvt; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --work; + --piv; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPSTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get block size */ + + nb = ilaenv_(&c__1, "CPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + cpstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1], + info); + goto L230; + + } else { + +/* Initialize PIV */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + piv[i__] = i__; +/* L100: */ + } + +/* Compute stopping value */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + work[i__] = a[i__2].r; +/* L110: */ + } + pvt = mymaxloc_(&work[1], &c__1, n, &c__1); + i__1 = pvt + pvt * a_dim1; + ajj = a[i__1].r; + if (ajj <= 0.f || sisnan_(&ajj)) { + *rank = 0; + *info = 1; + goto L230; + } + +/* Compute stopping value if not supplied */ + + if (*tol < 0.f) { + sstop = *n * slamch_("Epsilon") * ajj; + } else { + sstop = *tol; + } + + + if (upper) { + +/* Compute the Cholesky factorization P**T * A * P = U**H * U */ + + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + +/* Account for last block not being NB wide */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - k + 1; + jb = f2cmin(i__3,i__4); + +/* Set relevant part of first half of WORK to zero, */ +/* holds dot products */ + + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] = 0.f; +/* L120: */ + } + + i__3 = k + jb - 1; + for (j = k; j <= i__3; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__4 = *n; + for (i__ = j; i__ <= i__4; ++i__) { + + if (j > k) { + r_cnjg(&q__2, &a[j - 1 + i__ * a_dim1]); + i__5 = j - 1 + i__ * a_dim1; + q__1.r = q__2.r * a[i__5].r - q__2.i * a[i__5].i, + q__1.i = q__2.r * a[i__5].i + q__2.i * a[ + i__5].r; + work[i__] += q__1.r; + } + i__5 = i__ + i__ * a_dim1; + work[*n + i__] = a[i__5].r - work[i__]; + +/* L130: */ + } + + if (j > 1) { + i__4 = *n + j; + i__5 = *n << 1; + itemp = mymaxloc_(&work[1], &i__4, &i__5, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= sstop || sisnan_(&ajj)) { + i__4 = j + j * a_dim1; + a[i__4].r = ajj, a[i__4].i = 0.f; + goto L220; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + i__4 = pvt + pvt * a_dim1; + i__5 = j + j * a_dim1; + a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i; + i__4 = j - 1; + cswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt * + a_dim1 + 1], &c__1); + if (pvt < *n) { + i__4 = *n - pvt; + cswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[ + pvt + (pvt + 1) * a_dim1], lda); + } + i__4 = pvt - 1; + for (i__ = j + 1; i__ <= i__4; ++i__) { + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__5 = j + i__ * a_dim1; + r_cnjg(&q__1, &a[i__ + pvt * a_dim1]); + a[i__5].r = q__1.r, a[i__5].i = q__1.i; + i__5 = i__ + pvt * a_dim1; + a[i__5].r = ctemp.r, a[i__5].i = ctemp.i; +/* L140: */ + } + i__4 = j + pvt * a_dim1; + r_cnjg(&q__1, &a[j + pvt * a_dim1]); + a[i__4].r = q__1.r, a[i__4].i = q__1.i; + +/* Swap dot products and PIV */ + + stemp = work[j]; + work[j] = work[pvt]; + work[pvt] = stemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + i__4 = j + j * a_dim1; + a[i__4].r = ajj, a[i__4].i = 0.f; + +/* Compute elements J+1:N of row J. */ + + if (j < *n) { + i__4 = j - 1; + clacgv_(&i__4, &a[j * a_dim1 + 1], &c__1); + i__4 = j - k; + i__5 = *n - j; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Trans", &i__4, &i__5, &q__1, &a[k + (j + 1) * + a_dim1], lda, &a[k + j * a_dim1], &c__1, & + c_b1, &a[j + (j + 1) * a_dim1], lda); + i__4 = j - 1; + clacgv_(&i__4, &a[j * a_dim1 + 1], &c__1); + i__4 = *n - j; + r__1 = 1.f / ajj; + csscal_(&i__4, &r__1, &a[j + (j + 1) * a_dim1], lda); + } + +/* L150: */ + } + +/* Update trailing matrix, J already incremented */ + + if (k + jb <= *n) { + i__3 = *n - j + 1; + cherk_("Upper", "Conj Trans", &i__3, &jb, &c_b32, &a[k + + j * a_dim1], lda, &c_b33, &a[j + j * a_dim1], lda); + } + +/* L160: */ + } + + } else { + +/* Compute the Cholesky factorization P**T * A * P = L * L**H */ + + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + +/* Account for last block not being NB wide */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - k + 1; + jb = f2cmin(i__3,i__4); + +/* Set relevant part of first half of WORK to zero, */ +/* holds dot products */ + + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] = 0.f; +/* L170: */ + } + + i__3 = k + jb - 1; + for (j = k; j <= i__3; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__4 = *n; + for (i__ = j; i__ <= i__4; ++i__) { + + if (j > k) { + r_cnjg(&q__2, &a[i__ + (j - 1) * a_dim1]); + i__5 = i__ + (j - 1) * a_dim1; + q__1.r = q__2.r * a[i__5].r - q__2.i * a[i__5].i, + q__1.i = q__2.r * a[i__5].i + q__2.i * a[ + i__5].r; + work[i__] += q__1.r; + } + i__5 = i__ + i__ * a_dim1; + work[*n + i__] = a[i__5].r - work[i__]; + +/* L180: */ + } + + if (j > 1) { + i__4 = *n + j; + i__5 = *n << 1; + itemp = mymaxloc_(&work[1], &i__4, &i__5, &c__1); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= sstop || sisnan_(&ajj)) { + i__4 = j + j * a_dim1; + a[i__4].r = ajj, a[i__4].i = 0.f; + goto L220; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + i__4 = pvt + pvt * a_dim1; + i__5 = j + j * a_dim1; + a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i; + i__4 = j - 1; + cswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1], + lda); + if (pvt < *n) { + i__4 = *n - pvt; + cswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[ + pvt + 1 + pvt * a_dim1], &c__1); + } + i__4 = pvt - 1; + for (i__ = j + 1; i__ <= i__4; ++i__) { + r_cnjg(&q__1, &a[i__ + j * a_dim1]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__5 = i__ + j * a_dim1; + r_cnjg(&q__1, &a[pvt + i__ * a_dim1]); + a[i__5].r = q__1.r, a[i__5].i = q__1.i; + i__5 = pvt + i__ * a_dim1; + a[i__5].r = ctemp.r, a[i__5].i = ctemp.i; +/* L190: */ + } + i__4 = pvt + j * a_dim1; + r_cnjg(&q__1, &a[pvt + j * a_dim1]); + a[i__4].r = q__1.r, a[i__4].i = q__1.i; + +/* Swap dot products and PIV */ + + stemp = work[j]; + work[j] = work[pvt]; + work[pvt] = stemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + i__4 = j + j * a_dim1; + a[i__4].r = ajj, a[i__4].i = 0.f; + +/* Compute elements J+1:N of column J. */ + + if (j < *n) { + i__4 = j - 1; + clacgv_(&i__4, &a[j + a_dim1], lda); + i__4 = *n - j; + i__5 = j - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No Trans", &i__4, &i__5, &q__1, &a[j + 1 + k * + a_dim1], lda, &a[j + k * a_dim1], lda, &c_b1, + &a[j + 1 + j * a_dim1], &c__1); + i__4 = j - 1; + clacgv_(&i__4, &a[j + a_dim1], lda); + i__4 = *n - j; + r__1 = 1.f / ajj; + csscal_(&i__4, &r__1, &a[j + 1 + j * a_dim1], &c__1); + } + +/* L200: */ + } + +/* Update trailing matrix, J already incremented */ + + if (k + jb <= *n) { + i__3 = *n - j + 1; + cherk_("Lower", "No Trans", &i__3, &jb, &c_b32, &a[j + k * + a_dim1], lda, &c_b33, &a[j + j * a_dim1], lda); + } + +/* L210: */ + } + + } + } + +/* Ran to completion, A has full rank */ + + *rank = *n; + + goto L230; +L220: + +/* Rank is the number of steps completed. Set INFO = 1 to signal */ +/* that the factorization cannot be used to solve a system. */ + + *rank = j - 1; + *info = 1; + +L230: + return 0; + +/* End of CPSTRF */ + +} /* cpstrf_ */ + diff --git a/lapack-netlib/SRC/cptcon.c b/lapack-netlib/SRC/cptcon.c new file mode 100644 index 000000000..a4160cb5d --- /dev/null +++ b/lapack-netlib/SRC/cptcon.c @@ -0,0 +1,614 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPTCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO ) */ + +/* INTEGER INFO, N */ +/* REAL ANORM, RCOND */ +/* REAL D( * ), RWORK( * ) */ +/* COMPLEX E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTCON computes the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex Hermitian positive definite tridiagonal matrix */ +/* > using the factorization A = L*D*L**H or A = U**H*D*U computed by */ +/* > CPTTRF. */ +/* > */ +/* > Norm(inv(A)) is computed by a direct method, and the reciprocal of */ +/* > the condition number is computed as */ +/* > RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from the */ +/* > factorization of A, as computed by CPTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N-1) */ +/* > The (n-1) off-diagonal elements of the unit bidiagonal factor */ +/* > U or L from the factorization of A, as computed by CPTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the */ +/* > 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPTcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The method used is described in Nicholas J. Higham, "Efficient */ +/* > Algorithms for Computing the Condition Number of a Tridiagonal */ +/* > Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cptcon_(integer *n, real *d__, complex *e, real *anorm, + real *rcond, real *rwork, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + integer i__, ix; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + real ainvnm; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --rwork; + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*anorm < 0.f) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPTCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm == 0.f) { + return 0; + } + +/* Check that D(1:N) is positive. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= 0.f) { + return 0; + } +/* L10: */ + } + +/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ + +/* m(i,j) = abs(A(i,j)), i = j, */ +/* m(i,j) = -abs(A(i,j)), i .ne. j, */ + +/* and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**H. */ + +/* Solve M(L) * x = e. */ + + rwork[1] = 1.f; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + rwork[i__] = rwork[i__ - 1] * c_abs(&e[i__ - 1]) + 1.f; +/* L20: */ + } + +/* Solve D * M(L)**H * x = b. */ + + rwork[*n] /= d__[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + rwork[i__] = rwork[i__] / d__[i__] + rwork[i__ + 1] * c_abs(&e[i__]); +/* L30: */ + } + +/* Compute AINVNM = f2cmax(x(i)), 1<=i<=n. */ + + ix = isamax_(n, &rwork[1], &c__1); + ainvnm = (r__1 = rwork[ix], abs(r__1)); + +/* Compute the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + + return 0; + +/* End of CPTCON */ + +} /* cptcon_ */ + diff --git a/lapack-netlib/SRC/cpteqr.c b/lapack-netlib/SRC/cpteqr.c new file mode 100644 index 000000000..c397d784c --- /dev/null +++ b/lapack-netlib/SRC/cpteqr.c @@ -0,0 +1,667 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPTEQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTEQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) */ + +/* CHARACTER COMPZ */ +/* INTEGER INFO, LDZ, N */ +/* REAL D( * ), E( * ), WORK( * ) */ +/* COMPLEX Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTEQR computes all eigenvalues and, optionally, eigenvectors of a */ +/* > symmetric positive definite tridiagonal matrix by first factoring the */ +/* > matrix using SPTTRF and then calling CBDSQR to compute the singular */ +/* > values of the bidiagonal factor. */ +/* > */ +/* > This routine computes the eigenvalues of the positive definite */ +/* > tridiagonal matrix to high relative accuracy. This means that if the */ +/* > eigenvalues range over many orders of magnitude in size, then the */ +/* > small eigenvalues and corresponding eigenvectors will be computed */ +/* > more accurately than, for example, with the standard QR method. */ +/* > */ +/* > The eigenvectors of a full or band positive definite Hermitian matrix */ +/* > can also be found if CHETRD, CHPTRD, or CHBTRD has been used to */ +/* > reduce this matrix to tridiagonal form. (The reduction to */ +/* > tridiagonal form, however, may preclude the possibility of obtaining */ +/* > high relative accuracy in the small eigenvalues of the original */ +/* > matrix, if these eigenvalues range over many orders of magnitude.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only. */ +/* > = 'V': Compute eigenvectors of original Hermitian */ +/* > matrix also. Array Z contains the unitary matrix */ +/* > used to reduce the original matrix to tridiagonal */ +/* > form. */ +/* > = 'I': Compute eigenvectors of tridiagonal matrix also. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix. */ +/* > On normal exit, D contains the eigenvalues, in descending */ +/* > order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', the unitary matrix used in the */ +/* > reduction to tridiagonal form. */ +/* > On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */ +/* > original Hermitian matrix; */ +/* > if COMPZ = 'I', the orthonormal eigenvectors of the */ +/* > tridiagonal matrix. */ +/* > If INFO > 0 on exit, Z contains the eigenvectors associated */ +/* > with only the stored eigenvalues. */ +/* > If COMPZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > COMPZ = 'V' or 'I', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N the Cholesky factorization of the matrix could */ +/* > not be performed because the i-th principal minor */ +/* > was not positive definite. */ +/* > > N the SVD algorithm failed to converge; */ +/* > if INFO = N+i, i off-diagonal elements of the */ +/* > bidiagonal factor did not converge to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpteqr_(char *compz, integer *n, real *d__, real *e, + complex *z__, integer *ldz, real *work, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + complex c__[1] /* was [1][1] */; + integer i__; + extern logical lsame_(char *, char *); + complex vt[1] /* was [1][1] */; + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), xerbla_(char *, + integer *, ftnlen), cbdsqr_(char *, integer *, integer *, integer + *, integer *, real *, real *, complex *, integer *, complex *, + integer *, complex *, integer *, real *, integer *); + integer icompz; + extern /* Subroutine */ int spttrf_(integer *, real *, real *, integer *); + integer nru; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ==================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPTEQR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (icompz > 0) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1.f, z__[i__1].i = 0.f; + } + return 0; + } + if (icompz == 2) { + claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz); + } + +/* Call SPTTRF to factor the matrix. */ + + spttrf_(n, &d__[1], &e[1], info); + if (*info != 0) { + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(d__[i__]); +/* L10: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] *= d__[i__]; +/* L20: */ + } + +/* Call CBDSQR to compute the singular values/vectors of the */ +/* bidiagonal factor. */ + + if (icompz > 0) { + nru = *n; + } else { + nru = 0; + } + cbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[ + z_offset], ldz, c__, &c__1, &work[1], info); + +/* Square the singular values. */ + + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] *= d__[i__]; +/* L30: */ + } + } else { + *info = *n + *info; + } + + return 0; + +/* End of CPTEQR */ + +} /* cpteqr_ */ + diff --git a/lapack-netlib/SRC/cptrfs.c b/lapack-netlib/SRC/cptrfs.c new file mode 100644 index 000000000..9c6af6b7d --- /dev/null +++ b/lapack-netlib/SRC/cptrfs.c @@ -0,0 +1,1027 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPTRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, */ +/* FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* REAL BERR( * ), D( * ), DF( * ), FERR( * ), */ +/* $ RWORK( * ) */ +/* COMPLEX B( LDB, * ), E( * ), EF( * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is Hermitian positive definite */ +/* > and tridiagonal, and provides error bounds and backward error */ +/* > estimates for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the superdiagonal or the subdiagonal of the */ +/* > tridiagonal matrix A is stored and the form of the */ +/* > factorization: */ +/* > = 'U': E is the superdiagonal of A, and A = U**H*D*U; */ +/* > = 'L': E is the subdiagonal of A, and A = L*D*L**H. */ +/* > (The two forms are equivalent if A is real.) */ +/* > \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] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n real diagonal elements of the tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N-1) */ +/* > The (n-1) off-diagonal elements of the tridiagonal matrix A */ +/* > (see UPLO). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DF */ +/* > \verbatim */ +/* > DF is REAL array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from */ +/* > the factorization computed by CPTTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EF */ +/* > \verbatim */ +/* > EF is COMPLEX array, dimension (N-1) */ +/* > The (n-1) off-diagonal elements of the unit bidiagonal */ +/* > factor U or L from the factorization computed by CPTTRF */ +/* > (see UPLO). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by CPTTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 complexPTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cptrfs_(char *uplo, integer *n, integer *nrhs, real *d__, + complex *e, real *df, complex *ef, complex *b, integer *ldb, complex + *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, + integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11, + r__12; + complex q__1, q__2, q__3; + + /* Local variables */ + real safe1, safe2; + integer i__, j; + real s; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + integer count; + logical upper; + complex bi, cx, dx, ex; + integer ix; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + real lstres; + extern /* Subroutine */ int cpttrs_(char *, integer *, integer *, real *, + complex *, complex *, integer *, integer *); + real eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --df; + --ef; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPTRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = 4; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.f; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X. Also compute */ +/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */ + + if (upper) { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + bi.r = b[i__2].r, bi.i = b[i__2].i; + i__2 = j * x_dim1 + 1; + q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i; + dx.r = q__1.r, dx.i = q__1.i; + q__1.r = bi.r - dx.r, q__1.i = bi.i - dx.i; + work[1].r = q__1.r, work[1].i = q__1.i; + rwork[1] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(&bi), + abs(r__2)) + ((r__3 = dx.r, abs(r__3)) + (r__4 = + r_imag(&dx), abs(r__4))); + } else { + i__2 = j * b_dim1 + 1; + bi.r = b[i__2].r, bi.i = b[i__2].i; + i__2 = j * x_dim1 + 1; + q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i; + dx.r = q__1.r, dx.i = q__1.i; + i__2 = j * x_dim1 + 2; + q__1.r = e[1].r * x[i__2].r - e[1].i * x[i__2].i, q__1.i = e[ + 1].r * x[i__2].i + e[1].i * x[i__2].r; + ex.r = q__1.r, ex.i = q__1.i; + q__2.r = bi.r - dx.r, q__2.i = bi.i - dx.i; + q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i; + work[1].r = q__1.r, work[1].i = q__1.i; + i__2 = j * x_dim1 + 2; + rwork[1] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(&bi), + abs(r__2)) + ((r__3 = dx.r, abs(r__3)) + (r__4 = + r_imag(&dx), abs(r__4))) + ((r__5 = e[1].r, abs(r__5)) + + (r__6 = r_imag(&e[1]), abs(r__6))) * ((r__7 = x[ + i__2].r, abs(r__7)) + (r__8 = r_imag(&x[j * x_dim1 + + 2]), abs(r__8))); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + bi.r = b[i__3].r, bi.i = b[i__3].i; + r_cnjg(&q__2, &e[i__ - 1]); + i__3 = i__ - 1 + j * x_dim1; + q__1.r = q__2.r * x[i__3].r - q__2.i * x[i__3].i, q__1.i = + q__2.r * x[i__3].i + q__2.i * x[i__3].r; + cx.r = q__1.r, cx.i = q__1.i; + i__3 = i__; + i__4 = i__ + j * x_dim1; + q__1.r = d__[i__3] * x[i__4].r, q__1.i = d__[i__3] * x[ + i__4].i; + dx.r = q__1.r, dx.i = q__1.i; + i__3 = i__; + i__4 = i__ + 1 + j * x_dim1; + q__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i, + q__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[ + i__4].r; + ex.r = q__1.r, ex.i = q__1.i; + i__3 = i__; + q__3.r = bi.r - cx.r, q__3.i = bi.i - cx.i; + q__2.r = q__3.r - dx.r, q__2.i = q__3.i - dx.i; + q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + i__3 = i__ - 1; + i__4 = i__ - 1 + j * x_dim1; + i__5 = i__; + i__6 = i__ + 1 + j * x_dim1; + rwork[i__] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(& + bi), abs(r__2)) + ((r__3 = e[i__3].r, abs(r__3)) + + (r__4 = r_imag(&e[i__ - 1]), abs(r__4))) * (( + r__5 = x[i__4].r, abs(r__5)) + (r__6 = r_imag(&x[ + i__ - 1 + j * x_dim1]), abs(r__6))) + ((r__7 = + dx.r, abs(r__7)) + (r__8 = r_imag(&dx), abs(r__8)) + ) + ((r__9 = e[i__5].r, abs(r__9)) + (r__10 = + r_imag(&e[i__]), abs(r__10))) * ((r__11 = x[i__6] + .r, abs(r__11)) + (r__12 = r_imag(&x[i__ + 1 + j * + x_dim1]), abs(r__12))); +/* L30: */ + } + i__2 = *n + j * b_dim1; + bi.r = b[i__2].r, bi.i = b[i__2].i; + r_cnjg(&q__2, &e[*n - 1]); + i__2 = *n - 1 + j * x_dim1; + q__1.r = q__2.r * x[i__2].r - q__2.i * x[i__2].i, q__1.i = + q__2.r * x[i__2].i + q__2.i * x[i__2].r; + cx.r = q__1.r, cx.i = q__1.i; + i__2 = *n; + i__3 = *n + j * x_dim1; + q__1.r = d__[i__2] * x[i__3].r, q__1.i = d__[i__2] * x[i__3] + .i; + dx.r = q__1.r, dx.i = q__1.i; + i__2 = *n; + q__2.r = bi.r - cx.r, q__2.i = bi.i - cx.i; + q__1.r = q__2.r - dx.r, q__1.i = q__2.i - dx.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = *n - 1; + i__3 = *n - 1 + j * x_dim1; + rwork[*n] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(&bi), + abs(r__2)) + ((r__3 = e[i__2].r, abs(r__3)) + (r__4 = + r_imag(&e[*n - 1]), abs(r__4))) * ((r__5 = x[i__3].r, + abs(r__5)) + (r__6 = r_imag(&x[*n - 1 + j * x_dim1]), + abs(r__6))) + ((r__7 = dx.r, abs(r__7)) + (r__8 = + r_imag(&dx), abs(r__8))); + } + } else { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + bi.r = b[i__2].r, bi.i = b[i__2].i; + i__2 = j * x_dim1 + 1; + q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i; + dx.r = q__1.r, dx.i = q__1.i; + q__1.r = bi.r - dx.r, q__1.i = bi.i - dx.i; + work[1].r = q__1.r, work[1].i = q__1.i; + rwork[1] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(&bi), + abs(r__2)) + ((r__3 = dx.r, abs(r__3)) + (r__4 = + r_imag(&dx), abs(r__4))); + } else { + i__2 = j * b_dim1 + 1; + bi.r = b[i__2].r, bi.i = b[i__2].i; + i__2 = j * x_dim1 + 1; + q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i; + dx.r = q__1.r, dx.i = q__1.i; + r_cnjg(&q__2, &e[1]); + i__2 = j * x_dim1 + 2; + q__1.r = q__2.r * x[i__2].r - q__2.i * x[i__2].i, q__1.i = + q__2.r * x[i__2].i + q__2.i * x[i__2].r; + ex.r = q__1.r, ex.i = q__1.i; + q__2.r = bi.r - dx.r, q__2.i = bi.i - dx.i; + q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i; + work[1].r = q__1.r, work[1].i = q__1.i; + i__2 = j * x_dim1 + 2; + rwork[1] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(&bi), + abs(r__2)) + ((r__3 = dx.r, abs(r__3)) + (r__4 = + r_imag(&dx), abs(r__4))) + ((r__5 = e[1].r, abs(r__5)) + + (r__6 = r_imag(&e[1]), abs(r__6))) * ((r__7 = x[ + i__2].r, abs(r__7)) + (r__8 = r_imag(&x[j * x_dim1 + + 2]), abs(r__8))); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + bi.r = b[i__3].r, bi.i = b[i__3].i; + i__3 = i__ - 1; + i__4 = i__ - 1 + j * x_dim1; + q__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i, + q__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[ + i__4].r; + cx.r = q__1.r, cx.i = q__1.i; + i__3 = i__; + i__4 = i__ + j * x_dim1; + q__1.r = d__[i__3] * x[i__4].r, q__1.i = d__[i__3] * x[ + i__4].i; + dx.r = q__1.r, dx.i = q__1.i; + r_cnjg(&q__2, &e[i__]); + i__3 = i__ + 1 + j * x_dim1; + q__1.r = q__2.r * x[i__3].r - q__2.i * x[i__3].i, q__1.i = + q__2.r * x[i__3].i + q__2.i * x[i__3].r; + ex.r = q__1.r, ex.i = q__1.i; + i__3 = i__; + q__3.r = bi.r - cx.r, q__3.i = bi.i - cx.i; + q__2.r = q__3.r - dx.r, q__2.i = q__3.i - dx.i; + q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + i__3 = i__ - 1; + i__4 = i__ - 1 + j * x_dim1; + i__5 = i__; + i__6 = i__ + 1 + j * x_dim1; + rwork[i__] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(& + bi), abs(r__2)) + ((r__3 = e[i__3].r, abs(r__3)) + + (r__4 = r_imag(&e[i__ - 1]), abs(r__4))) * (( + r__5 = x[i__4].r, abs(r__5)) + (r__6 = r_imag(&x[ + i__ - 1 + j * x_dim1]), abs(r__6))) + ((r__7 = + dx.r, abs(r__7)) + (r__8 = r_imag(&dx), abs(r__8)) + ) + ((r__9 = e[i__5].r, abs(r__9)) + (r__10 = + r_imag(&e[i__]), abs(r__10))) * ((r__11 = x[i__6] + .r, abs(r__11)) + (r__12 = r_imag(&x[i__ + 1 + j * + x_dim1]), abs(r__12))); +/* L40: */ + } + i__2 = *n + j * b_dim1; + bi.r = b[i__2].r, bi.i = b[i__2].i; + i__2 = *n - 1; + i__3 = *n - 1 + j * x_dim1; + q__1.r = e[i__2].r * x[i__3].r - e[i__2].i * x[i__3].i, + q__1.i = e[i__2].r * x[i__3].i + e[i__2].i * x[i__3] + .r; + cx.r = q__1.r, cx.i = q__1.i; + i__2 = *n; + i__3 = *n + j * x_dim1; + q__1.r = d__[i__2] * x[i__3].r, q__1.i = d__[i__2] * x[i__3] + .i; + dx.r = q__1.r, dx.i = q__1.i; + i__2 = *n; + q__2.r = bi.r - cx.r, q__2.i = bi.i - cx.i; + q__1.r = q__2.r - dx.r, q__1.i = q__2.i - dx.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = *n - 1; + i__3 = *n - 1 + j * x_dim1; + rwork[*n] = (r__1 = bi.r, abs(r__1)) + (r__2 = r_imag(&bi), + abs(r__2)) + ((r__3 = e[i__2].r, abs(r__3)) + (r__4 = + r_imag(&e[*n - 1]), abs(r__4))) * ((r__5 = x[i__3].r, + abs(r__5)) + (r__6 = r_imag(&x[*n - 1 + j * x_dim1]), + abs(r__6))) + ((r__7 = dx.r, abs(r__7)) + (r__8 = + r_imag(&dx), abs(r__8))); + } + } + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2))) / rwork[i__]; + s = f2cmax(r__3,r__4); + } else { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(r__3,r__4); + } +/* 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.f <= lstres && count <= 5) { + +/* Update solution and try again. */ + + cpttrs_(uplo, n, &c__1, &df[1], &ef[1], &work[1], n, info); + caxpy_(n, &c_b16, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + ; + } else { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L60: */ + } + ix = isamax_(n, &rwork[1], &c__1); + ferr[j] = rwork[ix]; + +/* Estimate the norm of inv(A). */ + +/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ + +/* m(i,j) = abs(A(i,j)), i = j, */ +/* m(i,j) = -abs(A(i,j)), i .ne. j, */ + +/* and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**H. */ + +/* Solve M(L) * x = e. */ + + rwork[1] = 1.f; + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + rwork[i__] = rwork[i__ - 1] * c_abs(&ef[i__ - 1]) + 1.f; +/* L70: */ + } + +/* Solve D * M(L)**H * x = b. */ + + rwork[*n] /= df[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + rwork[i__] = rwork[i__] / df[i__] + rwork[i__ + 1] * c_abs(&ef[ + i__]); +/* L80: */ + } + +/* Compute norm(inv(A)) = f2cmax(x(i)), 1<=i<=n. */ + + ix = isamax_(n, &rwork[1], &c__1); + ferr[j] *= (r__1 = rwork[ix], abs(r__1)); + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__1 = lstres, r__2 = c_abs(&x[i__ + j * x_dim1]); + lstres = f2cmax(r__1,r__2); +/* L90: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L100: */ + } + + return 0; + +/* End of CPTRFS */ + +} /* cptrfs_ */ + diff --git a/lapack-netlib/SRC/cptsv.c b/lapack-netlib/SRC/cptsv.c new file mode 100644 index 000000000..38ede4ad9 --- /dev/null +++ b/lapack-netlib/SRC/cptsv.c @@ -0,0 +1,562 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPTSV computes the solution to system of linear equations A * X = B for PT matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO ) */ + +/* INTEGER INFO, LDB, N, NRHS */ +/* REAL D( * ) */ +/* COMPLEX B( LDB, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTSV computes the solution to a complex system of linear equations */ +/* > A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal */ +/* > matrix, and X and B are N-by-NRHS matrices. */ +/* > */ +/* > A is factored as A = L*D*L**H, and the factored form of A is then */ +/* > used to solve the system of equations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. On exit, the n diagonal elements of the diagonal matrix */ +/* > D from the factorization A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A. On exit, the (n-1) subdiagonal elements of the */ +/* > unit bidiagonal factor L from the L*D*L**H factorization of */ +/* > A. E can also be regarded as the superdiagonal of the unit */ +/* > bidiagonal factor U from the U**H*D*U factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i is not */ +/* > positive definite, and the solution has not been */ +/* > computed. The factorization has not been completed */ +/* > unless i = N. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPTsolve */ + +/* ===================================================================== */ +/* Subroutine */ int cptsv_(integer *n, integer *nrhs, real *d__, complex *e, + complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpttrf_( + integer *, real *, complex *, integer *), cpttrs_(char *, integer + *, integer *, real *, complex *, complex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPTSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the L*D*L**H (or U**H*D*U) factorization of A. */ + + cpttrf_(n, &d__[1], &e[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + cpttrs_("Lower", n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info); + } + return 0; + +/* End of CPTSV */ + +} /* cptsv_ */ + diff --git a/lapack-netlib/SRC/cptsvx.c b/lapack-netlib/SRC/cptsvx.c new file mode 100644 index 000000000..dad641a0b --- /dev/null +++ b/lapack-netlib/SRC/cptsvx.c @@ -0,0 +1,750 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CPTSVX computes the solution to system of linear equations A * X = B for PT matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, */ +/* RCOND, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER FACT */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* REAL RCOND */ +/* REAL BERR( * ), D( * ), DF( * ), FERR( * ), */ +/* $ RWORK( * ) */ +/* COMPLEX B( LDB, * ), E( * ), EF( * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTSVX uses the factorization A = L*D*L**H to compute the solution */ +/* > to a complex system of linear equations A*X = B, where A is an */ +/* > N-by-N Hermitian positive definite tridiagonal matrix and X and B */ +/* > are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L */ +/* > is a unit lower bidiagonal matrix and D is diagonal. The */ +/* > factorization can also be regarded as having the form */ +/* > A = U**H*D*U. */ +/* > */ +/* > 2. If the leading i-by-i principal minor is not positive definite, */ +/* > then the routine returns with INFO = i. Otherwise, the factored */ +/* > form of A is used to estimate the condition number of the matrix */ +/* > A. If the reciprocal of the condition number is less than machine */ +/* > precision, INFO = N+1 is returned as a warning, but the routine */ +/* > still goes on to solve for X and compute error bounds as */ +/* > described below. */ +/* > */ +/* > 3. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 4. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix */ +/* > A is supplied on entry. */ +/* > = 'F': On entry, DF and EF contain the factored form of A. */ +/* > D, E, DF, and EF will not be modified. */ +/* > = 'N': The matrix A will be copied to DF and EF and */ +/* > factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DF */ +/* > \verbatim */ +/* > DF is REAL array, dimension (N) */ +/* > If FACT = 'F', then DF is an input argument and on entry */ +/* > contains the n diagonal elements of the diagonal matrix D */ +/* > from the L*D*L**H factorization of A. */ +/* > If FACT = 'N', then DF is an output argument and on exit */ +/* > contains the n diagonal elements of the diagonal matrix D */ +/* > from the L*D*L**H factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EF */ +/* > \verbatim */ +/* > EF is COMPLEX array, dimension (N-1) */ +/* > If FACT = 'F', then EF is an input argument and on entry */ +/* > contains the (n-1) subdiagonal elements of the unit */ +/* > bidiagonal factor L from the L*D*L**H factorization of A. */ +/* > If FACT = 'N', then EF is an output argument and on exit */ +/* > contains the (n-1) subdiagonal elements of the unit */ +/* > bidiagonal factor L from the L*D*L**H factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The N-by-NRHS right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX 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 REAL */ +/* > 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 REAL array, dimension (NRHS) */ +/* > The forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in any */ +/* > element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the leading minor of order i of A is */ +/* > not positive definite, so the factorization */ +/* > could not be completed, and the solution has not */ +/* > been computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPTsolve */ + +/* ===================================================================== */ +/* Subroutine */ int cptsvx_(char *fact, integer *n, integer *nrhs, real *d__, + complex *e, real *df, complex *ef, complex *b, integer *ldb, complex + *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, + real *rwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + real anorm; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), scopy_(integer *, real *, integer *, real * + , integer *); + extern real slamch_(char *), clanht_(char *, integer *, real *, + complex *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen), cptcon_(integer *, real *, complex *, real *, + real *, real *, integer *), cptrfs_(char *, integer *, integer *, + real *, complex *, real *, complex *, complex *, integer *, + complex *, integer *, real *, real *, complex *, real *, integer * + ), cpttrf_(integer *, real *, complex *, integer *), + cpttrs_(char *, integer *, integer *, real *, complex *, complex * + , integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --df; + --ef; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPTSVX", &i__1, (ftnlen)6); + return 0; + } + + if (nofact) { + +/* Compute the L*D*L**H (or U**H*D*U) factorization of A. */ + + scopy_(n, &d__[1], &c__1, &df[1], &c__1); + if (*n > 1) { + i__1 = *n - 1; + ccopy_(&i__1, &e[1], &c__1, &ef[1], &c__1); + } + cpttrf_(n, &df[1], &ef[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.f; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = clanht_("1", n, &d__[1], &e[1]); + +/* Compute the reciprocal of the condition number of A. */ + + cptcon_(n, &df[1], &ef[1], &anorm, rcond, &rwork[1], info); + +/* Compute the solution vectors X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + cpttrs_("Lower", n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + cptrfs_("Lower", n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], + ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], + info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < slamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of CPTSVX */ + +} /* cptsvx_ */ + diff --git a/lapack-netlib/SRC/cpttrf.c b/lapack-netlib/SRC/cpttrf.c new file mode 100644 index 000000000..2b5be5b71 --- /dev/null +++ b/lapack-netlib/SRC/cpttrf.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 CPTTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTTRF( N, D, E, INFO ) */ + +/* INTEGER INFO, N */ +/* REAL D( * ) */ +/* COMPLEX E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTTRF computes the L*D*L**H factorization of a complex Hermitian */ +/* > positive definite tridiagonal matrix A. The factorization may also */ +/* > be regarded as having the form A = U**H *D*U. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix */ +/* > A. On exit, the n diagonal elements of the diagonal matrix */ +/* > D from the L*D*L**H factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix A. On exit, the (n-1) subdiagonal elements of the */ +/* > unit bidiagonal factor L from the L*D*L**H factorization of A. */ +/* > E can also be regarded as the superdiagonal of the unit */ +/* > bidiagonal factor U from the U**H *D*U factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, the leading minor of order k is not */ +/* > positive definite; if k < N, the factorization could not */ +/* > be completed, while if k = N, the factorization was */ +/* > completed, but D(N) <= 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexPTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpttrf_(integer *n, real *d__, complex *e, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + complex q__1; + + /* Local variables */ + real f, g; + integer i__, i4; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real eii, eir; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("CPTTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Compute the L*D*L**H (or U**H *D*U) factorization of A. */ + + i4 = (*n - 1) % 4; + i__1 = i4; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= 0.f) { + *info = i__; + goto L20; + } + i__2 = i__; + eir = e[i__2].r; + eii = r_imag(&e[i__]); + f = eir / d__[i__]; + g = eii / d__[i__]; + i__2 = i__; + q__1.r = f, q__1.i = g; + e[i__2].r = q__1.r, e[i__2].i = q__1.i; + d__[i__ + 1] = d__[i__ + 1] - f * eir - g * eii; +/* L10: */ + } + + i__1 = *n - 4; + for (i__ = i4 + 1; i__ <= i__1; i__ += 4) { + +/* Drop out of the loop if d(i) <= 0: the matrix is not positive */ +/* definite. */ + + if (d__[i__] <= 0.f) { + *info = i__; + goto L20; + } + +/* Solve for e(i) and d(i+1). */ + + i__2 = i__; + eir = e[i__2].r; + eii = r_imag(&e[i__]); + f = eir / d__[i__]; + g = eii / d__[i__]; + i__2 = i__; + q__1.r = f, q__1.i = g; + e[i__2].r = q__1.r, e[i__2].i = q__1.i; + d__[i__ + 1] = d__[i__ + 1] - f * eir - g * eii; + + if (d__[i__ + 1] <= 0.f) { + *info = i__ + 1; + goto L20; + } + +/* Solve for e(i+1) and d(i+2). */ + + i__2 = i__ + 1; + eir = e[i__2].r; + eii = r_imag(&e[i__ + 1]); + f = eir / d__[i__ + 1]; + g = eii / d__[i__ + 1]; + i__2 = i__ + 1; + q__1.r = f, q__1.i = g; + e[i__2].r = q__1.r, e[i__2].i = q__1.i; + d__[i__ + 2] = d__[i__ + 2] - f * eir - g * eii; + + if (d__[i__ + 2] <= 0.f) { + *info = i__ + 2; + goto L20; + } + +/* Solve for e(i+2) and d(i+3). */ + + i__2 = i__ + 2; + eir = e[i__2].r; + eii = r_imag(&e[i__ + 2]); + f = eir / d__[i__ + 2]; + g = eii / d__[i__ + 2]; + i__2 = i__ + 2; + q__1.r = f, q__1.i = g; + e[i__2].r = q__1.r, e[i__2].i = q__1.i; + d__[i__ + 3] = d__[i__ + 3] - f * eir - g * eii; + + if (d__[i__ + 3] <= 0.f) { + *info = i__ + 3; + goto L20; + } + +/* Solve for e(i+3) and d(i+4). */ + + i__2 = i__ + 3; + eir = e[i__2].r; + eii = r_imag(&e[i__ + 3]); + f = eir / d__[i__ + 3]; + g = eii / d__[i__ + 3]; + i__2 = i__ + 3; + q__1.r = f, q__1.i = g; + e[i__2].r = q__1.r, e[i__2].i = q__1.i; + d__[i__ + 4] = d__[i__ + 4] - f * eir - g * eii; +/* L110: */ + } + +/* Check d(n) for positive definiteness. */ + + if (d__[*n] <= 0.f) { + *info = *n; + } + +L20: + return 0; + +/* End of CPTTRF */ + +} /* cpttrf_ */ + diff --git a/lapack-netlib/SRC/cpttrs.c b/lapack-netlib/SRC/cpttrs.c new file mode 100644 index 000000000..d90f349f0 --- /dev/null +++ b/lapack-netlib/SRC/cpttrs.c @@ -0,0 +1,613 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPTTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* REAL D( * ) */ +/* COMPLEX B( LDB, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTTRS solves a tridiagonal system of the form */ +/* > A * X = B */ +/* > using the factorization A = U**H*D*U or A = L*D*L**H computed by CPTTRF. */ +/* > D is a diagonal matrix specified in the vector D, U (or L) is a unit */ +/* > bidiagonal matrix whose superdiagonal (subdiagonal) is specified in */ +/* > the vector E, and X and B are N by NRHS matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies the form of the factorization and whether the */ +/* > vector E is the superdiagonal of the upper bidiagonal factor */ +/* > U or the subdiagonal of the lower bidiagonal factor L. */ +/* > = 'U': A = U**H*D*U, E is the superdiagonal of U */ +/* > = 'L': A = L*D*L**H, E is the subdiagonal of L */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the tridiagonal matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from the */ +/* > factorization A = U**H*D*U or A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N-1) */ +/* > If UPLO = 'U', the (n-1) superdiagonal elements of the unit */ +/* > bidiagonal factor U from the factorization A = U**H*D*U. */ +/* > If UPLO = 'L', the (n-1) subdiagonal elements of the unit */ +/* > bidiagonal factor L from the factorization A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side vectors B for the system of */ +/* > linear equations. */ +/* > On exit, the solution vectors, X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexPTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cpttrs_(char *uplo, integer *n, integer *nrhs, real *d__, + complex *e, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer j, iuplo; + logical upper; + integer jb; + extern /* Subroutine */ int cptts2_(integer *, integer *, integer *, real + *, complex *, complex *, integer *); + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = *(unsigned char *)uplo == 'U' || *(unsigned char *)uplo == 'u'; + if (! upper && ! (*(unsigned char *)uplo == 'L' || *(unsigned char *)uplo + == 'l')) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CPTTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Determine the number of right-hand sides to solve at a time. */ + + if (*nrhs == 1) { + nb = 1; + } else { +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "CPTTRS", uplo, n, nrhs, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + nb = f2cmax(i__1,i__2); + } + +/* Decode UPLO */ + + if (upper) { + iuplo = 1; + } else { + iuplo = 0; + } + + if (nb >= *nrhs) { + cptts2_(&iuplo, n, nrhs, &d__[1], &e[1], &b[b_offset], ldb); + } else { + i__1 = *nrhs; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nrhs - j + 1; + jb = f2cmin(i__3,nb); + cptts2_(&iuplo, n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb); +/* L10: */ + } + } + + return 0; + +/* End of CPTTRS */ + +} /* cpttrs_ */ + diff --git a/lapack-netlib/SRC/cptts2.c b/lapack-netlib/SRC/cptts2.c new file mode 100644 index 000000000..f078ee6e9 --- /dev/null +++ b/lapack-netlib/SRC/cptts2.c @@ -0,0 +1,744 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CPTTS2 solves a tridiagonal system of the form AX=B using the L D LH factorization computed by +spttrf. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CPTTS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) */ + +/* INTEGER IUPLO, LDB, N, NRHS */ +/* REAL D( * ) */ +/* COMPLEX B( LDB, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CPTTS2 solves a tridiagonal system of the form */ +/* > A * X = B */ +/* > using the factorization A = U**H*D*U or A = L*D*L**H computed by CPTTRF. */ +/* > D is a diagonal matrix specified in the vector D, U (or L) is a unit */ +/* > bidiagonal matrix whose superdiagonal (subdiagonal) is specified in */ +/* > the vector E, and X and B are N by NRHS matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IUPLO */ +/* > \verbatim */ +/* > IUPLO is INTEGER */ +/* > Specifies the form of the factorization and whether the */ +/* > vector E is the superdiagonal of the upper bidiagonal factor */ +/* > U or the subdiagonal of the lower bidiagonal factor L. */ +/* > = 1: A = U**H *D*U, E is the superdiagonal of U */ +/* > = 0: A = L*D*L**H, E is the subdiagonal of L */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the tridiagonal matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D from the */ +/* > factorization A = U**H *D*U or A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N-1) */ +/* > If IUPLO = 1, the (n-1) superdiagonal elements of the unit */ +/* > bidiagonal factor U from the factorization A = U**H*D*U. */ +/* > If IUPLO = 0, the (n-1) subdiagonal elements of the unit */ +/* > bidiagonal factor L from the factorization A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side vectors B for the system of */ +/* > linear equations. */ +/* > On exit, the solution vectors, X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexPTcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cptts2_(integer *iuplo, integer *n, integer *nrhs, real * + d__, complex *e, complex *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer i__, j; + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (*n <= 1) { + if (*n == 1) { + r__1 = 1.f / d__[1]; + csscal_(nrhs, &r__1, &b[b_offset], ldb); + } + return 0; + } + + if (*iuplo == 1) { + +/* Solve A * X = B using the factorization A = U**H *D*U, */ +/* overwriting each right hand side vector with its solution. */ + + if (*nrhs <= 2) { + j = 1; +L5: + +/* Solve U**H * x = b. */ + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + i__4 = i__ - 1 + j * b_dim1; + r_cnjg(&q__3, &e[i__ - 1]); + q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i, q__2.i = b[ + i__4].r * q__3.i + b[i__4].i * q__3.r; + q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L10: */ + } + +/* Solve D * U * x = b. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + i__4 = i__; + q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4] + ; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L20: */ + } + for (i__ = *n - 1; i__ >= 1; --i__) { + i__1 = i__ + j * b_dim1; + i__2 = i__ + j * b_dim1; + i__3 = i__ + 1 + j * b_dim1; + i__4 = i__; + q__2.r = b[i__3].r * e[i__4].r - b[i__3].i * e[i__4].i, + q__2.i = b[i__3].r * e[i__4].i + b[i__3].i * e[i__4] + .r; + q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; +/* L30: */ + } + if (j < *nrhs) { + ++j; + goto L5; + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve U**H * x = b. */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ - 1 + j * b_dim1; + r_cnjg(&q__3, &e[i__ - 1]); + q__2.r = b[i__5].r * q__3.r - b[i__5].i * q__3.i, q__2.i = + b[i__5].r * q__3.i + b[i__5].i * q__3.r; + q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L40: */ + } + +/* Solve D * U * x = b. */ + + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + i__4 = *n; + q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4] + ; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + for (i__ = *n - 1; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + i__4 = i__; + q__2.r = b[i__3].r / d__[i__4], q__2.i = b[i__3].i / d__[ + i__4]; + i__5 = i__ + 1 + j * b_dim1; + i__6 = i__; + q__3.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i, + q__3.i = b[i__5].r * e[i__6].i + b[i__5].i * e[ + i__6].r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L50: */ + } +/* L60: */ + } + } + } else { + +/* Solve A * X = B using the factorization A = L*D*L**H, */ +/* overwriting each right hand side vector with its solution. */ + + if (*nrhs <= 2) { + j = 1; +L65: + +/* Solve L * x = b. */ + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + i__4 = i__ - 1 + j * b_dim1; + i__5 = i__ - 1; + q__2.r = b[i__4].r * e[i__5].r - b[i__4].i * e[i__5].i, + q__2.i = b[i__4].r * e[i__5].i + b[i__4].i * e[i__5] + .r; + q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L70: */ + } + +/* Solve D * L**H * x = b. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + i__4 = i__; + q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4] + ; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L80: */ + } + for (i__ = *n - 1; i__ >= 1; --i__) { + i__1 = i__ + j * b_dim1; + i__2 = i__ + j * b_dim1; + i__3 = i__ + 1 + j * b_dim1; + r_cnjg(&q__3, &e[i__]); + q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i, q__2.i = b[ + i__3].r * q__3.i + b[i__3].i * q__3.r; + q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; +/* L90: */ + } + if (j < *nrhs) { + ++j; + goto L65; + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve L * x = b. */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ - 1 + j * b_dim1; + i__6 = i__ - 1; + q__2.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i, + q__2.i = b[i__5].r * e[i__6].i + b[i__5].i * e[ + i__6].r; + q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L100: */ + } + +/* Solve D * L**H * x = b. */ + + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + i__4 = *n; + q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4] + ; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + for (i__ = *n - 1; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + i__4 = i__; + q__2.r = b[i__3].r / d__[i__4], q__2.i = b[i__3].i / d__[ + i__4]; + i__5 = i__ + 1 + j * b_dim1; + r_cnjg(&q__4, &e[i__]); + q__3.r = b[i__5].r * q__4.r - b[i__5].i * q__4.i, q__3.i = + b[i__5].r * q__4.i + b[i__5].i * q__4.r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L110: */ + } +/* L120: */ + } + } + } + + return 0; + +/* End of CPTTS2 */ + +} /* cptts2_ */ + diff --git a/lapack-netlib/SRC/crot.c b/lapack-netlib/SRC/crot.c new file mode 100644 index 000000000..9994d11c8 --- /dev/null +++ b/lapack-netlib/SRC/crot.c @@ -0,0 +1,589 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CROT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S ) */ + +/* INTEGER INCX, INCY, N */ +/* REAL C */ +/* COMPLEX S */ +/* COMPLEX CX( * ), CY( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CROT applies a plane rotation, where the cos (C) is real and the */ +/* > sin (S) is complex, and the vectors CX and CY are complex. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements in the vectors CX and CY. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CX */ +/* > \verbatim */ +/* > CX is COMPLEX array, dimension (N) */ +/* > On input, the vector X. */ +/* > On output, CX is overwritten with C*X + S*Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of CY. INCX <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CY */ +/* > \verbatim */ +/* > CY is COMPLEX array, dimension (N) */ +/* > On input, the vector Y. */ +/* > On output, CY is overwritten with -CONJG(S)*X + C*Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between successive values of CY. INCX <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is COMPLEX */ +/* > C and S define a rotation */ +/* > [ C S ] */ +/* > [ -conjg(S) C ] */ +/* > where C*C + S*CONJG(S) = 1.0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int crot_(integer *n, complex *cx, integer *incx, complex * + cy, integer *incy, real *c__, complex *s) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer i__; + complex stemp; + integer ix, iy; + + +/* -- 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 */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* Code for unequal increments or equal increments not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i; + i__3 = iy; + q__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, q__3.i = s->r * cy[ + i__3].i + s->i * cy[i__3].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + stemp.r = q__1.r, stemp.i = q__1.i; + i__2 = iy; + i__3 = iy; + q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i; + r_cnjg(&q__4, s); + i__4 = ix; + q__3.r = q__4.r * cx[i__4].r - q__4.i * cx[i__4].i, q__3.i = q__4.r * + cx[i__4].i + q__4.i * cx[i__4].r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + cy[i__2].r = q__1.r, cy[i__2].i = q__1.i; + i__2 = ix; + cx[i__2].r = stemp.r, cx[i__2].i = stemp.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* Code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i; + i__3 = i__; + q__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, q__3.i = s->r * cy[ + i__3].i + s->i * cy[i__3].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + stemp.r = q__1.r, stemp.i = q__1.i; + i__2 = i__; + i__3 = i__; + q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i; + r_cnjg(&q__4, s); + i__4 = i__; + q__3.r = q__4.r * cx[i__4].r - q__4.i * cx[i__4].i, q__3.i = q__4.r * + cx[i__4].i + q__4.i * cx[i__4].r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + cy[i__2].r = q__1.r, cy[i__2].i = q__1.i; + i__2 = i__; + cx[i__2].r = stemp.r, cx[i__2].i = stemp.i; +/* L30: */ + } + return 0; +} /* crot_ */ + diff --git a/lapack-netlib/SRC/cspcon.c b/lapack-netlib/SRC/cspcon.c new file mode 100644 index 000000000..4c976bf64 --- /dev/null +++ b/lapack-netlib/SRC/cspcon.c @@ -0,0 +1,627 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSPCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* REAL ANORM, RCOND */ +/* INTEGER IPIV( * ) */ +/* COMPLEX AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPCON estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex symmetric packed matrix A using the */ +/* > factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by CSPTRF, stored as a */ +/* > packed triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cspcon_(char *uplo, integer *n, complex *ap, integer * + ipiv, real *anorm, real *rcond, complex *work, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer kase, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real ainvnm; + extern /* Subroutine */ int csptrs_(char *, integer *, integer *, complex + *, integer *, complex *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --work; + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*anorm < 0.f) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSPCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm <= 0.f) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + ip = *n * (*n + 1) / 2; + for (i__ = *n; i__ >= 1; --i__) { + i__1 = ip; + if (ipiv[i__] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) { + return 0; + } + ip -= i__; +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + ip = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ip; + if (ipiv[i__] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) { + return 0; + } + ip = ip + *n - i__ + 1; +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + csptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info); + goto L30; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + + return 0; + +/* End of CSPCON */ + +} /* cspcon_ */ + diff --git a/lapack-netlib/SRC/cspmv.c b/lapack-netlib/SRC/cspmv.c new file mode 100644 index 000000000..b403de6ff --- /dev/null +++ b/lapack-netlib/SRC/cspmv.c @@ -0,0 +1,867 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed mat +rix */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) */ + +/* CHARACTER UPLO */ +/* INTEGER INCX, INCY, N */ +/* COMPLEX ALPHA, BETA */ +/* COMPLEX AP( * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPMV performs the matrix-vector operation */ +/* > */ +/* > y := alpha*A*x + beta*y, */ +/* > */ +/* > where alpha and beta are scalars, x and y are n element vectors and */ +/* > A is an n by n symmetric matrix, supplied in packed form. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the matrix A is supplied in the packed */ +/* > array AP as follows: */ +/* > */ +/* > UPLO = 'U' or 'u' The upper triangular part of A is */ +/* > supplied in AP. */ +/* > */ +/* > UPLO = 'L' or 'l' The lower triangular part of A is */ +/* > supplied in AP. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the order of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension at least */ +/* > ( ( N*( N + 1 ) )/2 ). */ +/* > Before entry, with UPLO = 'U' or 'u', the array AP must */ +/* > contain the upper triangular part of the symmetric matrix */ +/* > packed sequentially, column by column, so that AP( 1 ) */ +/* > contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* > and a( 2, 2 ) respectively, and so on. */ +/* > Before entry, with UPLO = 'L' or 'l', the array AP must */ +/* > contain the lower triangular part of the symmetric matrix */ +/* > packed sequentially, column by column, so that AP( 1 ) */ +/* > contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* > and a( 3, 1 ) respectively, and so on. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension at least */ +/* > ( 1 + ( N - 1 )*abs( INCX ) ). */ +/* > Before entry, the incremented array X must contain the N- */ +/* > element 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 COMPLEX */ +/* > 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 COMPLEX array, dimension at least */ +/* > ( 1 + ( N - 1 )*abs( INCY ) ). */ +/* > Before entry, the incremented array Y must contain the n */ +/* > element 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 December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int cspmv_(char *uplo, integer *n, complex *alpha, complex * + ap, complex *x, integer *incx, complex *beta, complex *y, integer * + incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer info; + complex temp1, temp2; + integer i__, j, k; + extern logical lsame_(char *, char *); + integer kk, ix, iy, jx, jy, kx, ky; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --y; + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 6; + } else if (*incy == 0) { + info = 9; + } + if (info != 0) { + xerbla_("CSPMV ", &info, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && + beta->i == 0.f)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + +/* First form y := beta*y. */ + + if (beta->r != 1.f || beta->i != 0.f) { + if (*incy == 1) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0.f, y[i__2].i = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0.f, y[i__2].i = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form y when AP contains the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = k; + i__4 = i__; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ++k; +/* L50: */ + } + i__2 = j; + i__3 = j; + i__4 = kk + j - 1; + q__3.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__3.i = + temp1.r * ap[i__4].i + temp1.i * ap[i__4].r; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + kk += j; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = iy; + i__4 = iy; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = k; + i__4 = ix; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__2 = jy; + i__3 = jy; + i__4 = kk + j - 1; + q__3.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__3.i = + temp1.r * ap[i__4].i + temp1.i * ap[i__4].r; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; + kk += j; +/* L80: */ + } + } + } else { + +/* Form y when AP contains the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = j; + i__3 = j; + i__4 = kk; + q__2.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__2.i = + temp1.r * ap[i__4].i + temp1.i * ap[i__4].r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = k; + i__4 = i__; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ++k; +/* L90: */ + } + i__2 = j; + i__3 = j; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + kk += *n - j + 1; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = jy; + i__3 = jy; + i__4 = kk; + q__2.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__2.i = + temp1.r * ap[i__4].i + temp1.i * ap[i__4].r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + i__3 = iy; + i__4 = iy; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = k; + i__4 = ix; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L110: */ + } + i__2 = jy; + i__3 = jy; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; + kk += *n - j + 1; +/* L120: */ + } + } + } + + return 0; + +/* End of CSPMV */ + +} /* cspmv_ */ + diff --git a/lapack-netlib/SRC/cspr.c b/lapack-netlib/SRC/cspr.c new file mode 100644 index 000000000..5f39f4868 --- /dev/null +++ b/lapack-netlib/SRC/cspr.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 CSPR performs the symmetrical rank-1 update of a complex symmetric packed matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP ) */ + +/* CHARACTER UPLO */ +/* INTEGER INCX, N */ +/* COMPLEX ALPHA */ +/* COMPLEX AP( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPR performs the symmetric rank 1 operation */ +/* > */ +/* > A := alpha*x*x**H + A, */ +/* > */ +/* > where alpha is a complex scalar, x is an n element vector and A is an */ +/* > n by n symmetric matrix, supplied in packed form. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the matrix A is supplied in the packed */ +/* > array AP as follows: */ +/* > */ +/* > UPLO = 'U' or 'u' The upper triangular part of A is */ +/* > supplied in AP. */ +/* > */ +/* > UPLO = 'L' or 'l' The lower triangular part of A is */ +/* > supplied in AP. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the order of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension at least */ +/* > ( 1 + ( N - 1 )*abs( INCX ) ). */ +/* > Before entry, the incremented array X must contain the N- */ +/* > element 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,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension at least */ +/* > ( ( N*( N + 1 ) )/2 ). */ +/* > Before entry, with UPLO = 'U' or 'u', the array AP must */ +/* > contain the upper triangular part of the symmetric matrix */ +/* > packed sequentially, column by column, so that AP( 1 ) */ +/* > contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* > and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* > AP is overwritten by the upper triangular part of the */ +/* > updated matrix. */ +/* > Before entry, with UPLO = 'L' or 'l', the array AP must */ +/* > contain the lower triangular part of the symmetric matrix */ +/* > packed sequentially, column by column, so that AP( 1 ) */ +/* > contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* > and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* > AP is overwritten by the lower triangular part of the */ +/* > updated matrix. */ +/* > Note that the imaginary parts of the diagonal elements need */ +/* > not be set, they are assumed to be zero, and on exit they */ +/* > are set to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int cspr_(char *uplo, integer *n, complex *alpha, complex *x, + integer *incx, complex *ap) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2; + + /* Local variables */ + integer info; + complex temp; + integer i__, j, k; + extern logical lsame_(char *, char *); + integer kk, ix, jx, kx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } + if (info != 0) { + xerbla_("CSPR ", &info, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++k; +/* L10: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = j; + q__2.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__2.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i + + q__2.i; + ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = k; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = jx; + q__2.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__2.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i + + q__2.i; + ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = kk; + i__3 = kk; + i__4 = j; + q__2.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__2.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i + + q__2.i; + ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++k; +/* L50: */ + } + } else { + i__2 = kk; + i__3 = kk; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = kk; + i__3 = kk; + i__4 = jx; + q__2.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__2.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i + + q__2.i; + ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = k; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; +/* L70: */ + } + } else { + i__2 = kk; + i__3 = kk; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + } + jx += *incx; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of CSPR */ + +} /* cspr_ */ + diff --git a/lapack-netlib/SRC/csprfs.c b/lapack-netlib/SRC/csprfs.c new file mode 100644 index 000000000..bfd99ea97 --- /dev/null +++ b/lapack-netlib/SRC/csprfs.c @@ -0,0 +1,910 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSPRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, */ +/* FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is symmetric indefinite */ +/* > and packed, and provides error bounds and backward error estimates */ +/* > for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the symmetric matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFP */ +/* > \verbatim */ +/* > AFP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The factored form of the matrix A. AFP contains the block */ +/* > diagonal matrix D and the multipliers used to obtain the */ +/* > factor U or L from the factorization A = U*D*U**T or */ +/* > A = L*D*L**T as computed by CSPTRF, stored as a packed */ +/* > triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by CSPTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csprfs_(char *uplo, integer *n, integer *nrhs, complex * + ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x, + integer *ldx, real *ferr, real *berr, complex *work, real *rwork, + integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + integer count; + extern /* Subroutine */ int cspmv_(char *, integer *, complex *, complex * + , complex *, integer *, complex *, complex *, integer *); + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + integer ik, kk; + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real lstres; + extern /* Subroutine */ int csptrs_(char *, integer *, integer *, complex + *, integer *, complex *, integer *, integer *); + real eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldx < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSPRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.f; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + q__1.r = -1.f, q__1.i = 0.f; + cspmv_(uplo, n, &q__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, & + work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[i__] = (r__1 = b[i__3].r, abs(r__1)) + (r__2 = r_imag(&b[ + i__ + j * b_dim1]), abs(r__2)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + kk = 1; + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + ik = kk; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ik; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[ik]), abs(r__2))) * xk; + i__4 = ik; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = r_imag(&ap[ + ik]), abs(r__2))) * ((r__3 = x[i__5].r, abs(r__3)) + + (r__4 = r_imag(&x[i__ + j * x_dim1]), abs(r__4) + )); + ++ik; +/* L40: */ + } + i__3 = kk + k - 1; + rwork[k] = rwork[k] + ((r__1 = ap[i__3].r, abs(r__1)) + (r__2 + = r_imag(&ap[kk + k - 1]), abs(r__2))) * xk + s; + kk += k; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + i__3 = kk; + rwork[k] += ((r__1 = ap[i__3].r, abs(r__1)) + (r__2 = r_imag(& + ap[kk]), abs(r__2))) * xk; + ik = kk + 1; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = ik; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[ik]), abs(r__2))) * xk; + i__4 = ik; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = r_imag(&ap[ + ik]), abs(r__2))) * ((r__3 = x[i__5].r, abs(r__3)) + + (r__4 = r_imag(&x[i__ + j * x_dim1]), abs(r__4) + )); + ++ik; +/* L60: */ + } + rwork[k] += s; + kk += *n - k + 1; +/* L70: */ + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2))) / rwork[i__]; + s = f2cmax(r__3,r__4); + } else { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(r__3,r__4); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { + +/* Update solution and try again. */ + + csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); + caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + ; + } else { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**T). */ + + csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L120: */ + } + csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * x_dim1; + r__3 = lstres, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[i__ + j * x_dim1]), abs(r__2)); + lstres = f2cmax(r__3,r__4); +/* L130: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of CSPRFS */ + +} /* csprfs_ */ + diff --git a/lapack-netlib/SRC/cspsv.c b/lapack-netlib/SRC/cspsv.c new file mode 100644 index 000000000..206683c7a --- /dev/null +++ b/lapack-netlib/SRC/cspsv.c @@ -0,0 +1,614 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSPSV computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix stored in packed format and X */ +/* > and B are N-by-NRHS matrices. */ +/* > */ +/* > The diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, D is symmetric and block diagonal with 1-by-1 */ +/* > and 2-by-2 diagonal blocks. The factored form of A is then used to */ +/* > solve the system of equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as */ +/* > a packed triangular matrix in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, as */ +/* > determined by CSPTRF. If IPIV(k) > 0, then rows and columns */ +/* > k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */ +/* > diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */ +/* > then rows and columns k-1 and -IPIV(k) were interchanged and */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */ +/* > IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */ +/* > -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */ +/* > diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, so the solution could not be */ +/* > computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the symmetric matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = aji) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cspsv_(char *uplo, integer *n, integer *nrhs, complex * + ap, integer *ipiv, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), csptrf_( + char *, integer *, complex *, integer *, integer *), + csptrs_(char *, integer *, integer *, complex *, integer *, + complex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSPSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + csptrf_(uplo, n, &ap[1], &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + csptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info); + + } + return 0; + +/* End of CSPSV */ + +} /* cspsv_ */ + diff --git a/lapack-netlib/SRC/cspsvx.c b/lapack-netlib/SRC/cspsvx.c new file mode 100644 index 000000000..229746eb6 --- /dev/null +++ b/lapack-netlib/SRC/cspsvx.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 CSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, */ +/* LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER FACT, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* REAL RCOND */ +/* INTEGER IPIV( * ) */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */ +/* > A = L*D*L**T to compute the solution to a complex system of linear */ +/* > equations A * X = B, where A is an N-by-N symmetric matrix stored */ +/* > in packed format and X and B are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > 2. If some D(i,i)=0, so that D is exactly singular, then the routine */ +/* > returns with INFO = i. Otherwise, the factored form of A is used */ +/* > to estimate the condition number of the matrix A. If the */ +/* > reciprocal of the condition number is less than machine precision, */ +/* > INFO = N+1 is returned as a warning, but the routine still goes on */ +/* > to solve for X and compute error bounds as described below. */ +/* > */ +/* > 3. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 4. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of A has been */ +/* > supplied on entry. */ +/* > = 'F': On entry, AFP and IPIV contain the factored form */ +/* > of A. AP, AFP and IPIV will not be modified. */ +/* > = 'N': The matrix A will be copied to AFP and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the symmetric matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFP */ +/* > \verbatim */ +/* > AFP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > If FACT = 'F', then AFP is an input argument and on entry */ +/* > contains the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as */ +/* > a packed triangular matrix in the same storage format as A. */ +/* > */ +/* > If FACT = 'N', then AFP is an output argument and on exit */ +/* > contains the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as */ +/* > a packed triangular matrix in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains details of the interchanges and the block structure */ +/* > of D, as determined by CSPTRF. */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* > columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* > IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* > interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains details of the interchanges and the block structure */ +/* > of D, as determined by CSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The N-by-NRHS right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX 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 REAL */ +/* > 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 REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: D(i,i) is exactly zero. The factorization */ +/* > has been completed but the factor D is exactly */ +/* > singular, so the solution and error bounds could */ +/* > not be computed. RCOND = 0 is returned. */ +/* > = N+1: D is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexOTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the symmetric matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = aji) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cspsvx_(char *fact, char *uplo, integer *n, integer * + nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer * + ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, + complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + real anorm; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + extern real slamch_(char *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + extern real clansp_(char *, char *, integer *, complex *, real *); + extern /* Subroutine */ int cspcon_(char *, integer *, complex *, integer + *, real *, real *, complex *, integer *), csprfs_(char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *, complex *, integer *, real *, real *, complex *, real * + , integer *), csptrf_(char *, integer *, complex *, + integer *, integer *), csptrs_(char *, integer *, integer + *, complex *, integer *, complex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSPSVX", &i__1, (ftnlen)6); + return 0; + } + + if (nofact) { + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + i__1 = *n * (*n + 1) / 2; + ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); + csptrf_(uplo, n, &afp[1], &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.f; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = clansp_("I", uplo, n, &ap[1], &rwork[1]); + +/* Compute the reciprocal of the condition number of A. */ + + cspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info); + +/* Compute the solution vectors X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + csptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + csprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[ + x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < slamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of CSPSVX */ + +} /* cspsvx_ */ + diff --git a/lapack-netlib/SRC/csptrf.c b/lapack-netlib/SRC/csptrf.c new file mode 100644 index 000000000..b1be038e9 --- /dev/null +++ b/lapack-netlib/SRC/csptrf.c @@ -0,0 +1,1178 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSPTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPTRF computes the factorization of a complex symmetric matrix A */ +/* > stored in packed format using the Bunch-Kaufman diagonal pivoting */ +/* > method: */ +/* > */ +/* > A = U*D*U**T or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L, stored as a packed triangular */ +/* > matrix overwriting A (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* > columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* > IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* > interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */ +/* > Company */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int csptrf_(char *uplo, integer *n, complex *ap, integer * + ipiv, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer imax, jmax; + extern /* Subroutine */ int cspr_(char *, integer *, complex *, complex *, + integer *, complex *); + integer i__, j, k; + complex t; + real alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer kstep; + logical upper; + complex r1, d11, d12, d21, d22; + integer kc, kk, kp; + real absakk; + complex wk; + integer kx; + extern integer icamax_(integer *, complex *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real colmax, rowmax; + integer knc, kpc, npp; + complex wkm1, wkp1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSPTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2 */ + + k = *n; + kc = (*n - 1) * *n / 2 + 1; +L10: + knc = kc; + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L110; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = kc + k - 1; + absakk = (r__1 = ap[i__1].r, abs(r__1)) + (r__2 = r_imag(&ap[kc + k - + 1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &ap[kc], &c__1); + i__1 = kc + imax - 1; + colmax = (r__1 = ap[i__1].r, abs(r__1)) + (r__2 = r_imag(&ap[kc + + imax - 1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + + rowmax = 0.f; + jmax = imax; + kx = imax * (imax + 1) / 2 + imax; + i__1 = k; + for (j = imax + 1; j <= i__1; ++j) { + i__2 = kx; + if ((r__1 = ap[i__2].r, abs(r__1)) + (r__2 = r_imag(&ap[ + kx]), abs(r__2)) > rowmax) { + i__2 = kx; + rowmax = (r__1 = ap[i__2].r, abs(r__1)) + (r__2 = + r_imag(&ap[kx]), abs(r__2)); + jmax = j; + } + kx += j; +/* L20: */ + } + kpc = (imax - 1) * imax / 2 + 1; + if (imax > 1) { + i__1 = imax - 1; + jmax = icamax_(&i__1, &ap[kpc], &c__1); +/* Computing MAX */ + i__1 = kpc + jmax - 1; + r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&ap[kpc + jmax - 1]), abs(r__2)); + rowmax = f2cmax(r__3,r__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = kpc + imax - 1; + if ((r__1 = ap[i__1].r, abs(r__1)) + (r__2 = r_imag(&ap[ + kpc + imax - 1]), abs(r__2)) >= alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + + kk = k - kstep + 1; + if (kstep == 2) { + knc = knc - k + 1; + } + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + i__1 = kp - 1; + cswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1); + kx = kpc + kp - 1; + i__1 = kk - 1; + for (j = kp + 1; j <= i__1; ++j) { + kx = kx + j - 1; + i__2 = knc + j - 1; + t.r = ap[i__2].r, t.i = ap[i__2].i; + i__2 = knc + j - 1; + i__3 = kx; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + i__2 = kx; + ap[i__2].r = t.r, ap[i__2].i = t.i; +/* L30: */ + } + i__1 = knc + kk - 1; + t.r = ap[i__1].r, t.i = ap[i__1].i; + i__1 = knc + kk - 1; + i__2 = kpc + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kpc + kp - 1; + ap[i__1].r = t.r, ap[i__1].i = t.i; + if (kstep == 2) { + i__1 = kc + k - 2; + t.r = ap[i__1].r, t.i = ap[i__1].i; + i__1 = kc + k - 2; + i__2 = kc + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc + kp - 1; + ap[i__1].r = t.r, ap[i__1].i = t.i; + } + } + +/* Update the leading submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ + +/* A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T */ + + c_div(&q__1, &c_b1, &ap[kc + k - 1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = k - 1; + q__1.r = -r1.r, q__1.i = -r1.i; + cspr_(uplo, &i__1, &q__1, &ap[kc], &c__1, &ap[1]); + +/* Store U(k) in column k */ + + i__1 = k - 1; + cscal_(&i__1, &r1, &ap[kc], &c__1); + } else { + +/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ + +/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T */ +/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T */ + + if (k > 2) { + + i__1 = k - 1 + (k - 1) * k / 2; + d12.r = ap[i__1].r, d12.i = ap[i__1].i; + c_div(&q__1, &ap[k - 1 + (k - 2) * (k - 1) / 2], &d12); + d22.r = q__1.r, d22.i = q__1.i; + c_div(&q__1, &ap[k + (k - 1) * k / 2], &d12); + d11.r = q__1.r, d11.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + c_div(&q__1, &t, &d12); + d12.r = q__1.r, d12.i = q__1.i; + + for (j = k - 2; j >= 1; --j) { + i__1 = j + (k - 2) * (k - 1) / 2; + q__3.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i, + q__3.i = d11.r * ap[i__1].i + d11.i * ap[i__1] + .r; + i__2 = j + (k - 1) * k / 2; + q__2.r = q__3.r - ap[i__2].r, q__2.i = q__3.i - ap[ + i__2].i; + q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i = + d12.r * q__2.i + d12.i * q__2.r; + wkm1.r = q__1.r, wkm1.i = q__1.i; + i__1 = j + (k - 1) * k / 2; + q__3.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i, + q__3.i = d22.r * ap[i__1].i + d22.i * ap[i__1] + .r; + i__2 = j + (k - 2) * (k - 1) / 2; + q__2.r = q__3.r - ap[i__2].r, q__2.i = q__3.i - ap[ + i__2].i; + q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i = + d12.r * q__2.i + d12.i * q__2.r; + wk.r = q__1.r, wk.i = q__1.i; + for (i__ = j; i__ >= 1; --i__) { + i__1 = i__ + (j - 1) * j / 2; + i__2 = i__ + (j - 1) * j / 2; + i__3 = i__ + (k - 1) * k / 2; + q__3.r = ap[i__3].r * wk.r - ap[i__3].i * wk.i, + q__3.i = ap[i__3].r * wk.i + ap[i__3].i * + wk.r; + q__2.r = ap[i__2].r - q__3.r, q__2.i = ap[i__2].i + - q__3.i; + i__4 = i__ + (k - 2) * (k - 1) / 2; + q__4.r = ap[i__4].r * wkm1.r - ap[i__4].i * + wkm1.i, q__4.i = ap[i__4].r * wkm1.i + ap[ + i__4].i * wkm1.r; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; +/* L40: */ + } + i__1 = j + (k - 1) * k / 2; + ap[i__1].r = wk.r, ap[i__1].i = wk.i; + i__1 = j + (k - 2) * (k - 1) / 2; + ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i; +/* L50: */ + } + + } + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + kc = knc - k; + goto L10; + + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; + kc = 1; + npp = *n * (*n + 1) / 2; +L60: + knc = kc; + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L110; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = kc; + absakk = (r__1 = ap[i__1].r, abs(r__1)) + (r__2 = r_imag(&ap[kc]), + abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &ap[kc + 1], &c__1); + i__1 = kc + imax - k; + colmax = (r__1 = ap[i__1].r, abs(r__1)) + (r__2 = r_imag(&ap[kc + + imax - k]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + rowmax = 0.f; + kx = kc + imax - k; + i__1 = imax - 1; + for (j = k; j <= i__1; ++j) { + i__2 = kx; + if ((r__1 = ap[i__2].r, abs(r__1)) + (r__2 = r_imag(&ap[ + kx]), abs(r__2)) > rowmax) { + i__2 = kx; + rowmax = (r__1 = ap[i__2].r, abs(r__1)) + (r__2 = + r_imag(&ap[kx]), abs(r__2)); + jmax = j; + } + kx = kx + *n - j; +/* L70: */ + } + kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1; + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + icamax_(&i__1, &ap[kpc + 1], &c__1); +/* Computing MAX */ + i__1 = kpc + jmax - imax; + r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&ap[kpc + jmax - imax]), abs(r__2)); + rowmax = f2cmax(r__3,r__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = kpc; + if ((r__1 = ap[i__1].r, abs(r__1)) + (r__2 = r_imag(&ap[ + kpc]), abs(r__2)) >= alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + + kk = k + kstep - 1; + if (kstep == 2) { + knc = knc + *n - k + 1; + } + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the trailing */ +/* submatrix A(k:n,k:n) */ + + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1], + &c__1); + } + kx = knc + kp - kk; + i__1 = kp - 1; + for (j = kk + 1; j <= i__1; ++j) { + kx = kx + *n - j + 1; + i__2 = knc + j - kk; + t.r = ap[i__2].r, t.i = ap[i__2].i; + i__2 = knc + j - kk; + i__3 = kx; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + i__2 = kx; + ap[i__2].r = t.r, ap[i__2].i = t.i; +/* L80: */ + } + i__1 = knc; + t.r = ap[i__1].r, t.i = ap[i__1].i; + i__1 = knc; + i__2 = kpc; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kpc; + ap[i__1].r = t.r, ap[i__1].i = t.i; + if (kstep == 2) { + i__1 = kc + 1; + t.r = ap[i__1].r, t.i = ap[i__1].i; + i__1 = kc + 1; + i__2 = kc + kp - k; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc + kp - k; + ap[i__1].r = t.r, ap[i__1].i = t.i; + } + } + +/* Update the trailing submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + + if (k < *n) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ + +/* A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T */ + + c_div(&q__1, &c_b1, &ap[kc]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = *n - k; + q__1.r = -r1.r, q__1.i = -r1.i; + cspr_(uplo, &i__1, &q__1, &ap[kc + 1], &c__1, &ap[kc + *n + - k + 1]); + +/* Store L(k) in column K */ + + i__1 = *n - k; + cscal_(&i__1, &r1, &ap[kc + 1], &c__1); + } + } else { + +/* 2-by-2 pivot block D(k): columns K and K+1 now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ + +/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**T */ +/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th */ +/* columns of L */ + + i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2; + d21.r = ap[i__1].r, d21.i = ap[i__1].i; + c_div(&q__1, &ap[k + 1 + k * ((*n << 1) - k - 1) / 2], & + d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &ap[k + (k - 1) * ((*n << 1) - k) / 2], &d21) + ; + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + c_div(&q__1, &t, &d21); + d21.r = q__1.r, d21.i = q__1.i; + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + (k - 1) * ((*n << 1) - k) / 2; + q__3.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i, + q__3.i = d11.r * ap[i__2].i + d11.i * ap[i__2] + .r; + i__3 = j + k * ((*n << 1) - k - 1) / 2; + q__2.r = q__3.r - ap[i__3].r, q__2.i = q__3.i - ap[ + i__3].i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + wk.r = q__1.r, wk.i = q__1.i; + i__2 = j + k * ((*n << 1) - k - 1) / 2; + q__3.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i, + q__3.i = d22.r * ap[i__2].i + d22.i * ap[i__2] + .r; + i__3 = j + (k - 1) * ((*n << 1) - k) / 2; + q__2.r = q__3.r - ap[i__3].r, q__2.i = q__3.i - ap[ + i__3].i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + wkp1.r = q__1.r, wkp1.i = q__1.i; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2; + i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2; + i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2; + q__3.r = ap[i__5].r * wk.r - ap[i__5].i * wk.i, + q__3.i = ap[i__5].r * wk.i + ap[i__5].i * + wk.r; + q__2.r = ap[i__4].r - q__3.r, q__2.i = ap[i__4].i + - q__3.i; + i__6 = i__ + k * ((*n << 1) - k - 1) / 2; + q__4.r = ap[i__6].r * wkp1.r - ap[i__6].i * + wkp1.i, q__4.i = ap[i__6].r * wkp1.i + ap[ + i__6].i * wkp1.r; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; +/* L90: */ + } + i__2 = j + (k - 1) * ((*n << 1) - k) / 2; + ap[i__2].r = wk.r, ap[i__2].i = wk.i; + i__2 = j + k * ((*n << 1) - k - 1) / 2; + ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i; +/* L100: */ + } + } + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + kc = knc + *n - k + 2; + goto L60; + + } + +L110: + return 0; + +/* End of CSPTRF */ + +} /* csptrf_ */ + diff --git a/lapack-netlib/SRC/csptri.c b/lapack-netlib/SRC/csptri.c new file mode 100644 index 000000000..28bb9ba02 --- /dev/null +++ b/lapack-netlib/SRC/csptri.c @@ -0,0 +1,931 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPTRI computes the inverse of a complex symmetric indefinite matrix */ +/* > A in packed storage using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by CSPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by CSPTRF, */ +/* > stored as a packed triangular matrix. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix, stored as a packed triangular matrix. The j-th column */ +/* > of inv(A) is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', */ +/* > AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csptri_(char *uplo, integer *n, complex *ap, integer * + ipiv, complex *work, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + complex q__1, q__2, q__3; + + /* Local variables */ + complex temp, akkp1, d__; + integer j, k; + complex t; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer kstep; + extern /* Subroutine */ int cspmv_(char *, integer *, complex *, complex * + , complex *, integer *, complex *, complex *, integer *); + logical upper; + complex ak; + integer kc, kp, kx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer kcnext, kpc, npp; + complex akp1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --work; + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSPTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + kp = *n * (*n + 1) / 2; + for (*info = *n; *info >= 1; --(*info)) { + i__1 = kp; + if (ipiv[*info] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) { + return 0; + } + kp -= *info; +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + kp = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = kp; + if (ipiv[*info] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) { + return 0; + } + kp = kp + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + kcnext = kc + k; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = kc + k - 1; + c_div(&q__1, &c_b1, &ap[kc + k - 1]); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, & + ap[kc], &c__1); + i__1 = kc + k - 1; + i__2 = kc + k - 1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = kcnext + k - 1; + t.r = ap[i__1].r, t.i = ap[i__1].i; + c_div(&q__1, &ap[kc + k - 1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &ap[kcnext + k], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &ap[kcnext + k - 1], &t); + akkp1.r = q__1.r, akkp1.i = q__1.i; + q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i + + ak.i * akp1.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i + * q__2.r; + d__.r = q__1.r, d__.i = q__1.i; + i__1 = kc + k - 1; + c_div(&q__1, &akp1, &d__); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = kcnext + k; + c_div(&q__1, &ak, &d__); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = kcnext + k - 1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, & + ap[kc], &c__1); + i__1 = kc + k - 1; + i__2 = kc + k - 1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = kcnext + k - 1; + i__2 = kcnext + k - 1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = k - 1; + ccopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, & + ap[kcnext], &c__1); + i__1 = kcnext + k; + i__2 = kcnext + k; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + } + kstep = 2; + kcnext = kcnext + k + 1; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + kpc = (kp - 1) * kp / 2 + 1; + i__1 = kp - 1; + cswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1); + kx = kpc + kp - 1; + i__1 = k - 1; + for (j = kp + 1; j <= i__1; ++j) { + kx = kx + j - 1; + i__2 = kc + j - 1; + temp.r = ap[i__2].r, temp.i = ap[i__2].i; + i__2 = kc + j - 1; + i__3 = kx; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + i__2 = kx; + ap[i__2].r = temp.r, ap[i__2].i = temp.i; +/* L40: */ + } + i__1 = kc + k - 1; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc + k - 1; + i__2 = kpc + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kpc + kp - 1; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + if (kstep == 2) { + i__1 = kc + k + k - 1; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc + k + k - 1; + i__2 = kc + k + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc + k + kp - 1; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + } + } + + k += kstep; + kc = kcnext; + goto L30; +L50: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + npp = *n * (*n + 1) / 2; + k = *n; + kc = npp; +L60: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L80; + } + + kcnext = kc - (*n - k + 2); + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = kc; + c_div(&q__1, &c_b1, &ap[kc]); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cspmv_(uplo, &i__1, &q__1, &ap[kc + *n - k + 1], &work[1], & + c__1, &c_b2, &ap[kc + 1], &c__1); + i__1 = kc; + i__2 = kc; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = kcnext + 1; + t.r = ap[i__1].r, t.i = ap[i__1].i; + c_div(&q__1, &ap[kcnext], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &ap[kc], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &ap[kcnext + 1], &t); + akkp1.r = q__1.r, akkp1.i = q__1.i; + q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i + + ak.i * akp1.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i + * q__2.r; + d__.r = q__1.r, d__.i = q__1.i; + i__1 = kcnext; + c_div(&q__1, &akp1, &d__); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = kc; + c_div(&q__1, &ak, &d__); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = kcnext + 1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], & + c__1, &c_b2, &ap[kc + 1], &c__1); + i__1 = kc; + i__2 = kc; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = kcnext + 1; + i__2 = kcnext + 1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], & + c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = *n - k; + ccopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], & + c__1, &c_b2, &ap[kcnext + 2], &c__1); + i__1 = kcnext; + i__2 = kcnext; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1); + q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i; + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + } + kstep = 2; + kcnext -= *n - k + 3; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1; + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], & + c__1); + } + kx = kc + kp - k; + i__1 = kp - 1; + for (j = k + 1; j <= i__1; ++j) { + kx = kx + *n - j + 1; + i__2 = kc + j - k; + temp.r = ap[i__2].r, temp.i = ap[i__2].i; + i__2 = kc + j - k; + i__3 = kx; + ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i; + i__2 = kx; + ap[i__2].r = temp.r, ap[i__2].i = temp.i; +/* L70: */ + } + i__1 = kc; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc; + i__2 = kpc; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kpc; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + if (kstep == 2) { + i__1 = kc - *n + k - 1; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc - *n + k - 1; + i__2 = kc - *n + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc - *n + kp - 1; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + } + } + + k -= kstep; + kc = kcnext; + goto L60; +L80: + ; + } + + return 0; + +/* End of CSPTRI */ + +} /* csptri_ */ + diff --git a/lapack-netlib/SRC/csptrs.c b/lapack-netlib/SRC/csptrs.c new file mode 100644 index 000000000..98124d539 --- /dev/null +++ b/lapack-netlib/SRC/csptrs.c @@ -0,0 +1,931 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSPTRS solves a system of linear equations A*X = B with a complex */ +/* > symmetric matrix A stored in packed format using the factorization */ +/* > A = U*D*U**T or A = L*D*L**T computed by CSPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by CSPTRF, stored as a */ +/* > packed triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csptrs_(char *uplo, integer *n, integer *nrhs, complex * + ap, integer *ipiv, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + complex q__1, q__2, q__3; + + /* Local variables */ + complex akm1k; + integer j, k; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + complex denom; + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), cgeru_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *), + cswap_(integer *, complex *, integer *, complex *, integer *); + logical upper; + complex ak, bk; + integer kc, kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + complex akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --ap; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSPTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* First solve U*D*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + kc = *n * (*n + 1) / 2 + 1; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + kc -= k; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgeru_(&i__1, nrhs, &q__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, & + b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + c_div(&q__1, &c_b1, &ap[kc + k - 1]); + cscal_(nrhs, &q__1, &b[k + b_dim1], ldb); + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K-1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k - 1) { + cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in columns K-1 and K of A. */ + + i__1 = k - 2; + q__1.r = -1.f, q__1.i = 0.f; + cgeru_(&i__1, nrhs, &q__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, & + b[b_dim1 + 1], ldb); + i__1 = k - 2; + q__1.r = -1.f, q__1.i = 0.f; + cgeru_(&i__1, nrhs, &q__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = kc + k - 2; + akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i; + c_div(&q__1, &ap[kc - 1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &ap[kc + k - 1], &akm1k); + ak.r = q__1.r, ak.i = q__1.i; + q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i + + akm1.i * ak.r; + q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f; + denom.r = q__1.r, denom.i = q__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k); + bkm1.r = q__1.r, bkm1.i = q__1.i; + c_div(&q__1, &b[k + j * b_dim1], &akm1k); + bk.r = q__1.r, bk.i = q__1.i; + i__2 = k - 1 + j * b_dim1; + q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i; + c_div(&q__1, &q__2, &denom); + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + i__2 = k + j * b_dim1; + q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * + bk.i + akm1.i * bk.r; + q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i; + c_div(&q__1, &q__2, &denom); + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L20: */ + } + kc = kc - k + 1; + k += -2; + } + + goto L10; +L30: + +/* Next solve U**T*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L40: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(U**T(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &ap[kc] + , &c__1, &c_b1, &b[k + b_dim1], ldb); + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc += k; + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &ap[kc] + , &c__1, &c_b1, &b[k + b_dim1], ldb); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &ap[kc + + k], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb); + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc = kc + (k << 1) + 1; + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* First solve L*D*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L60: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L80; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgeru_(&i__1, nrhs, &q__1, &ap[kc + 1], &c__1, &b[k + b_dim1], + ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + c_div(&q__1, &c_b1, &ap[kc]); + cscal_(nrhs, &q__1, &b[k + b_dim1], ldb); + kc = kc + *n - k + 1; + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K+1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k + 1) { + cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k < *n - 1) { + i__1 = *n - k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgeru_(&i__1, nrhs, &q__1, &ap[kc + 2], &c__1, &b[k + b_dim1], + ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgeru_(&i__1, nrhs, &q__1, &ap[kc + *n - k + 2], &c__1, &b[k + + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = kc + 1; + akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i; + c_div(&q__1, &ap[kc], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &ap[kc + *n - k + 1], &akm1k); + ak.r = q__1.r, ak.i = q__1.i; + q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i + + akm1.i * ak.r; + q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f; + denom.r = q__1.r, denom.i = q__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + c_div(&q__1, &b[k + j * b_dim1], &akm1k); + bkm1.r = q__1.r, bkm1.i = q__1.i; + c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k); + bk.r = q__1.r, bk.i = q__1.i; + i__2 = k + j * b_dim1; + q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i; + c_div(&q__1, &q__2, &denom); + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + i__2 = k + 1 + j * b_dim1; + q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * + bk.i + akm1.i * bk.r; + q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i; + c_div(&q__1, &q__2, &denom); + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L70: */ + } + kc = kc + (*n - k << 1) + 1; + k += 2; + } + + goto L60; +L80: + +/* Next solve L**T*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + kc = *n * (*n + 1) / 2 + 1; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + kc -= *n - k + 1; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L**T(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1], + ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1], + ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + b_dim1], ldb); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1], + ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k - 1 + + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc -= *n - k + 2; + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of CSPTRS */ + +} /* csptrs_ */ + diff --git a/lapack-netlib/SRC/csrscl.c b/lapack-netlib/SRC/csrscl.c new file mode 100644 index 000000000..980b55dce --- /dev/null +++ b/lapack-netlib/SRC/csrscl.c @@ -0,0 +1,552 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSRSCL multiplies a vector by the reciprocal of a real scalar. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSRSCL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSRSCL( N, SA, SX, INCX ) */ + +/* INTEGER INCX, N */ +/* REAL SA */ +/* COMPLEX SX( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSRSCL multiplies an n-element complex vector x by the real scalar */ +/* > 1/a. This is done without overflow or underflow as long as */ +/* > the final result x/a does not overflow or underflow. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of components of the vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SA */ +/* > \verbatim */ +/* > SA is REAL */ +/* > The scalar a which is used to divide each component of x. */ +/* > SA must be >= 0, or the subroutine will divide by zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SX */ +/* > \verbatim */ +/* > SX is COMPLEX array, dimension */ +/* > (1+(N-1)*abs(INCX)) */ +/* > The n-element vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of the vector SX. */ +/* > > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int csrscl_(integer *n, real *sa, complex *sx, integer *incx) +{ + real cden; + logical done; + real cnum, cden1, cnum1; + extern /* Subroutine */ int slabad_(real *, real *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *); + real bignum, smlnum, mul; + + +/* -- 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 */ + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + +/* Get machine parameters */ + + smlnum = slamch_("S"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + +/* Initialize the denominator to SA and the numerator to 1. */ + + cden = *sa; + cnum = 1.f; + +L10: + cden1 = cden * smlnum; + cnum1 = cnum / bignum; + if (abs(cden1) > abs(cnum) && cnum != 0.f) { + +/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ + + mul = smlnum; + done = FALSE_; + cden = cden1; + } else if (abs(cnum1) > abs(cden)) { + +/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ + + mul = bignum; + done = FALSE_; + cnum = cnum1; + } else { + +/* Multiply X by CNUM / CDEN and return. */ + + mul = cnum / cden; + done = TRUE_; + } + +/* Scale the vector X by MUL */ + + csscal_(n, &mul, &sx[1], incx); + + if (! done) { + goto L10; + } + + return 0; + +/* End of CSRSCL */ + +} /* csrscl_ */ + diff --git a/lapack-netlib/SRC/cstedc.c b/lapack-netlib/SRC/cstedc.c new file mode 100644 index 000000000..1f24e7ffe --- /dev/null +++ b/lapack-netlib/SRC/cstedc.c @@ -0,0 +1,934 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSTEDC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSTEDC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, */ +/* LRWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER COMPZ */ +/* INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* REAL D( * ), E( * ), RWORK( * ) */ +/* COMPLEX WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSTEDC computes all eigenvalues and, optionally, eigenvectors of a */ +/* > symmetric tridiagonal matrix using the divide and conquer method. */ +/* > The eigenvectors of a full or band complex Hermitian matrix can also */ +/* > be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this */ +/* > matrix to tridiagonal form. */ +/* > */ +/* > This code makes very mild assumptions about floating point */ +/* > arithmetic. It will work on machines with a guard digit in */ +/* > add/subtract, or on those binary machines without guard digits */ +/* > which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ +/* > It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. See SLAED3 for details. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only. */ +/* > = 'I': Compute eigenvectors of tridiagonal matrix also. */ +/* > = 'V': Compute eigenvectors of original Hermitian matrix */ +/* > also. On entry, Z contains the unitary matrix used */ +/* > to reduce the original matrix to tridiagonal form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the diagonal elements of the tridiagonal matrix. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > On entry, the subdiagonal elements of the tridiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ,N) */ +/* > On entry, if COMPZ = 'V', then Z contains the unitary */ +/* > matrix used in the reduction to tridiagonal form. */ +/* > On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ +/* > orthonormal eigenvectors of the original Hermitian matrix, */ +/* > and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ +/* > of the symmetric tridiagonal matrix. */ +/* > If COMPZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If eigenvectors are desired, then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1. */ +/* > If COMPZ = 'V' and N > 1, LWORK must be at least N*N. */ +/* > Note that for COMPZ = 'V', then if N is less than or */ +/* > equal to the minimum divide size, usually 25, then LWORK need */ +/* > only be 1. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal sizes of the WORK, RWORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (MAX(1,LRWORK)) */ +/* > On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > The dimension of the array RWORK. */ +/* > If COMPZ = 'N' or N <= 1, LRWORK must be at least 1. */ +/* > If COMPZ = 'V' and N > 1, LRWORK must be at least */ +/* > 1 + 3*N + 2*N*lg N + 4*N**2 , */ +/* > where lg( N ) = smallest integer k such */ +/* > that 2**k >= N. */ +/* > If COMPZ = 'I' and N > 1, LRWORK must be at least */ +/* > 1 + 4*N + 2*N**2 . */ +/* > Note that for COMPZ = 'I' or 'V', then if N is less than or */ +/* > equal to the minimum divide size, usually 25, then LRWORK */ +/* > need only be f2cmax(1,2*(N-1)). */ +/* > */ +/* > If LRWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK, RWORK */ +/* > and IWORK arrays, returns these values as the first entries */ +/* > of the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If COMPZ = 'N' or N <= 1, LIWORK must be at least 1. */ +/* > If COMPZ = 'V' or N > 1, LIWORK must be at least */ +/* > 6 + 6*N + 5*N*lg N. */ +/* > If COMPZ = 'I' or N > 1, LIWORK must be at least */ +/* > 3 + 5*N . */ +/* > Note that for COMPZ = 'I' or 'V', then if N is less than or */ +/* > equal to the minimum divide size, usually 25, then LIWORK */ +/* > need only be 1. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK, RWORK */ +/* > and IWORK arrays, returns these values as the first entries */ +/* > of the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: 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 complexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Jeff Rutter, Computer Science Division, University of California */ +/* > at Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int cstedc_(char *compz, integer *n, real *d__, real *e, + complex *z__, integer *ldz, complex *work, integer *lwork, real * + rwork, integer *lrwork, integer *iwork, integer *liwork, integer * + info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4; + real r__1, r__2; + + /* Local variables */ + real tiny; + integer i__, j, k, m; + real p; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer lwmin; + extern /* Subroutine */ int claed0_(integer *, integer *, real *, real *, + complex *, integer *, complex *, integer *, real *, integer *, + integer *); + integer start, ii, ll; + extern /* Subroutine */ int clacrm_(integer *, integer *, complex *, + integer *, real *, integer *, complex *, integer *, real *); + extern real slamch_(char *); + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer finish; + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *), sstedc_(char *, integer *, real *, real *, real *, + integer *, real *, integer *, integer *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *, + real *, integer *); + integer liwmin, icompz; + extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *, + complex *, integer *, real *, integer *); + real orgnrm; + extern real slanst_(char *, integer *, real *, real *); + extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *); + integer lrwmin; + logical lquery; + integer smlsiz; + extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, + real *, integer *, real *, integer *); + integer lgn; + real eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) { + *info = -6; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + + smlsiz = ilaenv_(&c__9, "CSTEDC", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + if (*n <= 1 || icompz == 0) { + lwmin = 1; + liwmin = 1; + lrwmin = 1; + } else if (*n <= smlsiz) { + lwmin = 1; + liwmin = 1; + lrwmin = *n - 1 << 1; + } else if (icompz == 1) { + lgn = (integer) (log((real) (*n)) / log(2.f)); + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + lwmin = *n * *n; +/* Computing 2nd power */ + i__1 = *n; + lrwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); + liwmin = *n * 6 + 6 + *n * 5 * lgn; + } else if (icompz == 2) { + lwmin = 1; +/* Computing 2nd power */ + i__1 = *n; + lrwmin = (*n << 2) + 1 + (i__1 * i__1 << 1); + liwmin = *n * 5 + 3; + } + work[1].r = (real) lwmin, work[1].i = 0.f; + rwork[1] = (real) lrwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*lrwork < lrwmin && ! lquery) { + *info = -10; + } else if (*liwork < liwmin && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSTEDC", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (icompz != 0) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1.f, z__[i__1].i = 0.f; + } + return 0; + } + +/* If the following conditional clause is removed, then the routine */ +/* will use the Divide and Conquer routine to compute only the */ +/* eigenvalues, which requires (3N + 3N**2) real workspace and */ +/* (2 + 5N + 2N lg(N)) integer workspace. */ +/* Since on many architectures SSTERF is much faster than any other */ +/* algorithm for finding eigenvalues only, it is used here */ +/* as the default. If the conditional clause is removed, then */ +/* information on the size of workspace needs to be changed. */ + +/* If COMPZ = 'N', use SSTERF to compute the eigenvalues. */ + + if (icompz == 0) { + ssterf_(n, &d__[1], &e[1], info); + goto L70; + } + +/* If N is smaller than the minimum divide size (SMLSIZ+1), then */ +/* solve the problem with another solver. */ + + if (*n <= smlsiz) { + + csteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1], + info); + + } else { + +/* If COMPZ = 'I', we simply call SSTEDC instead. */ + + if (icompz == 2) { + slaset_("Full", n, n, &c_b17, &c_b18, &rwork[1], n); + ll = *n * *n + 1; + i__1 = *lrwork - ll + 1; + sstedc_("I", n, &d__[1], &e[1], &rwork[1], n, &rwork[ll], &i__1, & + iwork[1], liwork, info); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * z_dim1; + i__4 = (j - 1) * *n + i__; + z__[i__3].r = rwork[i__4], z__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + goto L70; + } + +/* From now on, only option left to be handled is COMPZ = 'V', */ +/* i.e. ICOMPZ = 1. */ + +/* Scale. */ + + orgnrm = slanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.f) { + goto L70; + } + + eps = slamch_("Epsilon"); + + start = 1; + +/* while ( START <= N ) */ + +L30: + if (start <= *n) { + +/* Let FINISH be the position of the next subdiagonal entry */ +/* such that E( FINISH ) <= TINY or FINISH = N if no such */ +/* subdiagonal exists. The matrix identified by the elements */ +/* between START and FINISH constitutes an independent */ +/* sub-problem. */ + + finish = start; +L40: + if (finish < *n) { + tiny = eps * sqrt((r__1 = d__[finish], abs(r__1))) * sqrt(( + r__2 = d__[finish + 1], abs(r__2))); + if ((r__1 = e[finish], abs(r__1)) > tiny) { + ++finish; + goto L40; + } + } + +/* (Sub) Problem determined. Compute its size and solve it. */ + + m = finish - start + 1; + if (m > smlsiz) { + +/* Scale. */ + + orgnrm = slanst_("M", &m, &d__[start], &e[start]); + slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ + start], &m, info); + i__1 = m - 1; + i__2 = m - 1; + slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ + start], &i__2, info); + + claed0_(n, &m, &d__[start], &e[start], &z__[start * z_dim1 + + 1], ldz, &work[1], n, &rwork[1], &iwork[1], info); + if (*info > 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % + (m + 1) + start - 1; + goto L70; + } + +/* Scale back. */ + + slascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ + start], &m, info); + + } else { + ssteqr_("I", &m, &d__[start], &e[start], &rwork[1], &m, & + rwork[m * m + 1], info); + clacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, & + work[1], n, &rwork[m * m + 1]); + clacpy_("A", n, &m, &work[1], n, &z__[start * z_dim1 + 1], + ldz); + if (*info > 0) { + *info = start * (*n + 1) + finish; + goto L70; + } + } + + start = finish + 1; + goto L30; + } + +/* endwhile */ + + +/* Use Selection Sort to minimize swaps of eigenvectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } +/* L50: */ + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], + &c__1); + } +/* L60: */ + } + } + +L70: + work[1].r = (real) lwmin, work[1].i = 0.f; + rwork[1] = (real) lrwmin; + iwork[1] = liwmin; + + return 0; + +/* End of CSTEDC */ + +} /* cstedc_ */ + diff --git a/lapack-netlib/SRC/cstegr.c b/lapack-netlib/SRC/cstegr.c new file mode 100644 index 000000000..5ae3aaaca --- /dev/null +++ b/lapack-netlib/SRC/cstegr.c @@ -0,0 +1,698 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSTEGR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSTEGR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, */ +/* ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, */ +/* LIWORK, INFO ) */ + +/* CHARACTER JOBZ, RANGE */ +/* INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N */ +/* REAL ABSTOL, VL, VU */ +/* INTEGER ISUPPZ( * ), IWORK( * ) */ +/* REAL D( * ), E( * ), W( * ), WORK( * ) */ +/* COMPLEX Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSTEGR computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ +/* > a well defined set of pairwise different real eigenvalues, the corresponding */ +/* > real eigenvectors are pairwise orthogonal. */ +/* > */ +/* > The spectrum may be computed either completely or partially by specifying */ +/* > either an interval (VL,VU] or a range of indices IL:IU for the desired */ +/* > eigenvalues. */ +/* > */ +/* > CSTEGR is a compatibility wrapper around the improved CSTEMR routine. */ +/* > See SSTEMR for further details. */ +/* > */ +/* > One important change is that the ABSTOL parameter no longer provides any */ +/* > benefit and hence is no longer used. */ +/* > */ +/* > Note : CSTEGR and CSTEMR work only on machines which follow */ +/* > IEEE-754 floating-point standard in their handling of infinities and */ +/* > NaNs. Normal execution may create these exceptiona values and hence */ +/* > may abort due to a floating point exception in environments which */ +/* > do not conform to the IEEE-754 standard. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': all eigenvalues will be found. */ +/* > = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* > will be found. */ +/* > = 'I': the IL-th through IU-th eigenvalues will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the N diagonal elements of the tridiagonal matrix */ +/* > T. On exit, D is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > On entry, the (N-1) subdiagonal elements of the tridiagonal */ +/* > matrix T in elements 1 to N-1 of E. E(N) need not be set on */ +/* > input, but is used internally as workspace. */ +/* > On exit, E is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL */ +/* > */ +/* > If RANGE='V', the lower bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is REAL */ +/* > */ +/* > If RANGE='V', the upper bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > smallest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IU */ +/* > \verbatim */ +/* > IU is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > largest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ABSTOL */ +/* > \verbatim */ +/* > ABSTOL is REAL */ +/* > Unused. Was the absolute error tolerance for the */ +/* > eigenvalues/eigenvectors in previous versions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of eigenvalues found. 0 <= M <= N. */ +/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ, f2cmax(1,M) ) */ +/* > If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ +/* > contain the orthonormal eigenvectors of the matrix T */ +/* > corresponding to the selected eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > Note: the user must ensure that at least f2cmax(1,M) columns are */ +/* > supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* > is not known in advance and an upper bound must be used. */ +/* > Supplying N columns is always safe. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The i-th computed eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* > ISUPPZ( 2*i ). This is relevant in the case when the matrix */ +/* > is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal */ +/* > (and minimal) LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,18*N) */ +/* > if JOBZ = 'V', and LWORK >= f2cmax(1,12*N) if JOBZ = 'N'. */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (LIWORK) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N) */ +/* > if the eigenvectors are desired, and LIWORK >= f2cmax(1,8*N) */ +/* > if only the eigenvalues are to be computed. */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, INFO */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = 1X, internal error in SLARRE, */ +/* > if INFO = 2X, internal error in CLARRV. */ +/* > Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ +/* > the nonzero error code returned by SLARRE or */ +/* > CLARRV, respectively. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Inderjit Dhillon, IBM Almaden, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int cstegr_(char *jobz, char *range, integer *n, real *d__, + real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, + integer *m, real *w, complex *z__, integer *ldz, integer *isuppz, + real *work, integer *lwork, integer *iwork, integer *liwork, integer * + info) +{ + /* System generated locals */ + integer z_dim1, z_offset; + + /* Local variables */ + extern /* Subroutine */ int cstemr_(char *, char *, integer *, real *, + real *, real *, real *, integer *, integer *, integer *, real *, + complex *, integer *, integer *, integer *, logical *, real *, + integer *, integer *, integer *, integer *); + logical tryrac; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + *info = 0; + tryrac = FALSE_; + cstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[ + z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1] + , liwork, info); + +/* End of CSTEGR */ + + return 0; +} /* cstegr_ */ + diff --git a/lapack-netlib/SRC/cstein.c b/lapack-netlib/SRC/cstein.c new file mode 100644 index 000000000..b9c619614 --- /dev/null +++ b/lapack-netlib/SRC/cstein.c @@ -0,0 +1,913 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSTEIN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSTEIN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, */ +/* IWORK, IFAIL, INFO ) */ + +/* INTEGER INFO, LDZ, M, N */ +/* INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), */ +/* $ IWORK( * ) */ +/* REAL D( * ), E( * ), W( * ), WORK( * ) */ +/* COMPLEX Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSTEIN computes the eigenvectors of a real symmetric tridiagonal */ +/* > matrix T corresponding to specified eigenvalues, using inverse */ +/* > iteration. */ +/* > */ +/* > The maximum number of iterations allowed for each eigenvector is */ +/* > specified by an internal parameter MAXITS (currently set to 5). */ +/* > */ +/* > Although the eigenvectors are real, they are stored in a complex */ +/* > array, which may be passed to CUNMTR or CUPMTR for back */ +/* > transformation to the eigenvectors of a complex Hermitian matrix */ +/* > which was reduced to tridiagonal form. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the tridiagonal matrix */ +/* > T, stored in elements 1 to N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of eigenvectors to be found. 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The first M elements of W contain the eigenvalues for */ +/* > which eigenvectors are to be computed. The eigenvalues */ +/* > should be grouped by split-off block and ordered from */ +/* > smallest to largest within the block. ( The output array */ +/* > W from SSTEBZ with ORDER = 'B' is expected here. ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IBLOCK */ +/* > \verbatim */ +/* > IBLOCK is INTEGER array, dimension (N) */ +/* > The submatrix indices associated with the corresponding */ +/* > eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */ +/* > the first submatrix from the top, =2 if W(i) belongs to */ +/* > the second submatrix, etc. ( The output array IBLOCK */ +/* > from SSTEBZ is expected here. ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into submatrices. */ +/* > The first submatrix consists of rows/columns 1 to */ +/* > ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ +/* > through ISPLIT( 2 ), etc. */ +/* > ( The output array ISPLIT from SSTEBZ is expected here. ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ, M) */ +/* > The computed eigenvectors. The eigenvector associated */ +/* > with the eigenvalue W(i) is stored in the i-th column of */ +/* > Z. Any vector which fails to converge is set to its current */ +/* > iterate after MAXITS iterations. */ +/* > The imaginary parts of the eigenvectors are set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (5*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAIL */ +/* > \verbatim */ +/* > IFAIL is INTEGER array, dimension (M) */ +/* > On normal exit, all elements of IFAIL are zero. */ +/* > If one or more eigenvectors fail to converge after */ +/* > MAXITS iterations, then their indices are stored in */ +/* > array IFAIL. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, then i eigenvectors failed to converge */ +/* > in MAXITS iterations. Their indices are stored in */ +/* > array IFAIL. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > MAXITS INTEGER, default = 5 */ +/* > The maximum number of iterations performed. */ +/* > */ +/* > EXTRA INTEGER, default = 2 */ +/* > The number of iterations performed after norm growth */ +/* > criterion is satisfied, should be at least 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cstein_(integer *n, real *d__, real *e, integer *m, real + *w, integer *iblock, integer *isplit, complex *z__, integer *ldz, + real *work, integer *iwork, integer *ifail, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4, r__5; + complex q__1; + + /* Local variables */ + integer jblk, nblk, jmax; + extern real snrm2_(integer *, real *, integer *); + integer i__, j, iseed[4], gpind, iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer b1, j1; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real ortol; + integer indrv1, indrv2, indrv3, indrv4, indrv5, bn, jr; + real xj; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slagtf_( + integer *, real *, real *, real *, real *, real *, real *, + integer *, integer *); + integer nrmchk; + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *, + real *, real *, integer *, real *, real *, integer *); + integer blksiz; + real onenrm, pertol; + extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real + *); + real stpcrt, scl, eps, ctr, sep, nrm, tol; + integer its; + real xjm, eps1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + --iblock; + --isplit; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + *info = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + + if (*n < 0) { + *info = -1; + } else if (*m < 0 || *m > *n) { + *info = -4; + } else if (*ldz < f2cmax(1,*n)) { + *info = -9; + } else { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + if (iblock[j] < iblock[j - 1]) { + *info = -6; + goto L30; + } + if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { + *info = -5; + goto L30; + } +/* L20: */ + } +L30: + ; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSTEIN", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } else if (*n == 1) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1.f, z__[i__1].i = 0.f; + return 0; + } + +/* Get machine constants. */ + + eps = slamch_("Precision"); + +/* Initialize seed for random number generator SLARNV. */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__ - 1] = 1; +/* L40: */ + } + +/* Initialize pointers. */ + + indrv1 = 0; + indrv2 = indrv1 + *n; + indrv3 = indrv2 + *n; + indrv4 = indrv3 + *n; + indrv5 = indrv4 + *n; + +/* Compute eigenvectors of matrix blocks. */ + + j1 = 1; + i__1 = iblock[*m]; + for (nblk = 1; nblk <= i__1; ++nblk) { + +/* Find starting and ending indices of block nblk. */ + + if (nblk == 1) { + b1 = 1; + } else { + b1 = isplit[nblk - 1] + 1; + } + bn = isplit[nblk]; + blksiz = bn - b1 + 1; + if (blksiz == 1) { + goto L60; + } + gpind = j1; + +/* Compute reorthogonalization criterion and stopping criterion. */ + + onenrm = (r__1 = d__[b1], abs(r__1)) + (r__2 = e[b1], abs(r__2)); +/* Computing MAX */ + r__3 = onenrm, r__4 = (r__1 = d__[bn], abs(r__1)) + (r__2 = e[bn - 1], + abs(r__2)); + onenrm = f2cmax(r__3,r__4); + i__2 = bn - 1; + for (i__ = b1 + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__4 = onenrm, r__5 = (r__1 = d__[i__], abs(r__1)) + (r__2 = e[ + i__ - 1], abs(r__2)) + (r__3 = e[i__], abs(r__3)); + onenrm = f2cmax(r__4,r__5); +/* L50: */ + } + ortol = onenrm * .001f; + + stpcrt = sqrt(.1f / blksiz); + +/* Loop through eigenvalues of block nblk. */ + +L60: + jblk = 0; + i__2 = *m; + for (j = j1; j <= i__2; ++j) { + if (iblock[j] != nblk) { + j1 = j; + goto L180; + } + ++jblk; + xj = w[j]; + +/* Skip all the work if the block size is one. */ + + if (blksiz == 1) { + work[indrv1 + 1] = 1.f; + goto L140; + } + +/* If eigenvalues j and j-1 are too close, add a relatively */ +/* small perturbation. */ + + if (jblk > 1) { + eps1 = (r__1 = eps * xj, abs(r__1)); + pertol = eps1 * 10.f; + sep = xj - xjm; + if (sep < pertol) { + xj = xjm + pertol; + } + } + + its = 0; + nrmchk = 0; + +/* Get random starting vector. */ + + slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]); + +/* Copy the matrix T so it won't be destroyed in factorization. */ + + scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1); + i__3 = blksiz - 1; + scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1); + i__3 = blksiz - 1; + scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1); + +/* Compute LU factors with partial pivoting ( PT = LU ) */ + + tol = 0.f; + slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[ + indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo); + +/* Update iteration count. */ + +L70: + ++its; + if (its > 5) { + goto L120; + } + +/* Normalize and scale the righthand side vector Pb. */ + + jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1); +/* Computing MAX */ + r__3 = eps, r__4 = (r__1 = work[indrv4 + blksiz], abs(r__1)); + scl = blksiz * onenrm * f2cmax(r__3,r__4) / (r__2 = work[indrv1 + + jmax], abs(r__2)); + sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); + +/* Solve the system LU = Pb. */ + + slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], & + work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[ + indrv1 + 1], &tol, &iinfo); + +/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */ +/* close enough. */ + + if (jblk == 1) { + goto L110; + } + if ((r__1 = xj - xjm, abs(r__1)) > ortol) { + gpind = j; + } + if (gpind != j) { + i__3 = j - 1; + for (i__ = gpind; i__ <= i__3; ++i__) { + ctr = 0.f; + i__4 = blksiz; + for (jr = 1; jr <= i__4; ++jr) { + i__5 = b1 - 1 + jr + i__ * z_dim1; + ctr += work[indrv1 + jr] * z__[i__5].r; +/* L80: */ + } + i__4 = blksiz; + for (jr = 1; jr <= i__4; ++jr) { + i__5 = b1 - 1 + jr + i__ * z_dim1; + work[indrv1 + jr] -= ctr * z__[i__5].r; +/* L90: */ + } +/* L100: */ + } + } + +/* Check the infinity norm of the iterate. */ + +L110: + jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1); + nrm = (r__1 = work[indrv1 + jmax], abs(r__1)); + +/* Continue for additional iterations after norm reaches */ +/* stopping criterion. */ + + if (nrm < stpcrt) { + goto L70; + } + ++nrmchk; + if (nrmchk < 3) { + goto L70; + } + + goto L130; + +/* If stopping criterion was not satisfied, update info and */ +/* store eigenvector number in array ifail. */ + +L120: + ++(*info); + ifail[*info] = j; + +/* Accept iterate as jth eigenvector. */ + +L130: + scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1); + jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1); + if (work[indrv1 + jmax] < 0.f) { + scl = -scl; + } + sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); +L140: + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * z_dim1; + z__[i__4].r = 0.f, z__[i__4].i = 0.f; +/* L150: */ + } + i__3 = blksiz; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = b1 + i__ - 1 + j * z_dim1; + i__5 = indrv1 + i__; + q__1.r = work[i__5], q__1.i = 0.f; + z__[i__4].r = q__1.r, z__[i__4].i = q__1.i; +/* L160: */ + } + +/* Save the shift to check eigenvalue spacing at next */ +/* iteration. */ + + xjm = xj; + +/* L170: */ + } +L180: + ; + } + + return 0; + +/* End of CSTEIN */ + +} /* cstein_ */ + diff --git a/lapack-netlib/SRC/cstemr.c b/lapack-netlib/SRC/cstemr.c new file mode 100644 index 000000000..147451d9a --- /dev/null +++ b/lapack-netlib/SRC/cstemr.c @@ -0,0 +1,1231 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSTEMR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSTEMR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, */ +/* M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, */ +/* IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, RANGE */ +/* LOGICAL TRYRAC */ +/* INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N */ +/* REAL VL, VU */ +/* INTEGER ISUPPZ( * ), IWORK( * ) */ +/* REAL D( * ), E( * ), W( * ), WORK( * ) */ +/* COMPLEX Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSTEMR computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ +/* > a well defined set of pairwise different real eigenvalues, the corresponding */ +/* > real eigenvectors are pairwise orthogonal. */ +/* > */ +/* > The spectrum may be computed either completely or partially by specifying */ +/* > either an interval (VL,VU] or a range of indices IL:IU for the desired */ +/* > eigenvalues. */ +/* > */ +/* > Depending on the number of desired eigenvalues, these are computed either */ +/* > by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */ +/* > computed by the use of various suitable L D L^T factorizations near clusters */ +/* > of close eigenvalues (referred to as RRRs, Relatively Robust */ +/* > Representations). An informal sketch of the algorithm follows. */ +/* > */ +/* > For each unreduced block (submatrix) of T, */ +/* > (a) Compute T - sigma I = L D L^T, so that L and D */ +/* > define all the wanted eigenvalues to high relative accuracy. */ +/* > This means that small relative changes in the entries of D and L */ +/* > cause only small relative changes in the eigenvalues and */ +/* > eigenvectors. The standard (unfactored) representation of the */ +/* > tridiagonal matrix T does not have this property in general. */ +/* > (b) Compute the eigenvalues to suitable accuracy. */ +/* > If the eigenvectors are desired, the algorithm attains full */ +/* > accuracy of the computed eigenvalues only right before */ +/* > the corresponding vectors have to be computed, see steps c) and d). */ +/* > (c) For each cluster of close eigenvalues, select a new */ +/* > shift close to the cluster, find a new factorization, and refine */ +/* > the shifted eigenvalues to suitable accuracy. */ +/* > (d) For each eigenvalue with a large enough relative separation compute */ +/* > the corresponding eigenvector by forming a rank revealing twisted */ +/* > factorization. Go back to (c) for any clusters that remain. */ +/* > */ +/* > For more details, see: */ +/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ +/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ +/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ +/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ +/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ +/* > 2004. Also LAPACK Working Note 154. */ +/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ +/* > tridiagonal eigenvalue/eigenvector problem", */ +/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ +/* > UC Berkeley, May 1997. */ +/* > */ +/* > Further Details */ +/* > 1.CSTEMR works only on machines which follow IEEE-754 */ +/* > floating-point standard in their handling of infinities and NaNs. */ +/* > This permits the use of efficient inner loops avoiding a check for */ +/* > zero divisors. */ +/* > */ +/* > 2. LAPACK routines can be used to reduce a complex Hermitean matrix to */ +/* > real symmetric tridiagonal form. */ +/* > */ +/* > (Any complex Hermitean tridiagonal matrix has real values on its diagonal */ +/* > and potentially complex numbers on its off-diagonals. By applying a */ +/* > similarity transform with an appropriate diagonal matrix */ +/* > diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean */ +/* > matrix can be transformed into a real symmetric matrix and complex */ +/* > arithmetic can be entirely avoided.) */ +/* > */ +/* > While the eigenvectors of the real symmetric tridiagonal matrix are real, */ +/* > the eigenvectors of original complex Hermitean matrix have complex entries */ +/* > in general. */ +/* > Since LAPACK drivers overwrite the matrix data with the eigenvectors, */ +/* > CSTEMR accepts complex workspace to facilitate interoperability */ +/* > with CUNMTR or CUPMTR. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': all eigenvalues will be found. */ +/* > = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* > will be found. */ +/* > = 'I': the IL-th through IU-th eigenvalues will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the N diagonal elements of the tridiagonal matrix */ +/* > T. On exit, D is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > On entry, the (N-1) subdiagonal elements of the tridiagonal */ +/* > matrix T in elements 1 to N-1 of E. E(N) need not be set on */ +/* > input, but is used internally as workspace. */ +/* > On exit, E is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL */ +/* > */ +/* > If RANGE='V', the lower bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is REAL */ +/* > */ +/* > If RANGE='V', the upper bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > smallest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IU */ +/* > \verbatim */ +/* > IU is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > largest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of eigenvalues found. 0 <= M <= N. */ +/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The first M elements contain the selected eigenvalues in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ, f2cmax(1,M) ) */ +/* > If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ +/* > contain the orthonormal eigenvectors of the matrix T */ +/* > corresponding to the selected eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > Note: the user must ensure that at least f2cmax(1,M) columns are */ +/* > supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* > is not known in advance and can be computed with a workspace */ +/* > query by setting NZC = -1, see below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NZC */ +/* > \verbatim */ +/* > NZC is INTEGER */ +/* > The number of eigenvectors to be held in the array Z. */ +/* > If RANGE = 'A', then NZC >= f2cmax(1,N). */ +/* > If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */ +/* > If RANGE = 'I', then NZC >= IU-IL+1. */ +/* > If NZC = -1, then a workspace query is assumed; the */ +/* > routine calculates the number of columns of the array Z that */ +/* > are needed to hold the eigenvectors. */ +/* > This value is returned as the first entry of the Z array, and */ +/* > no error message related to NZC is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The i-th computed eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* > ISUPPZ( 2*i ). This is relevant in the case when the matrix */ +/* > is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] TRYRAC */ +/* > \verbatim */ +/* > TRYRAC is LOGICAL */ +/* > If TRYRAC = .TRUE., indicates that the code should check whether */ +/* > the tridiagonal matrix defines its eigenvalues to high relative */ +/* > accuracy. If so, the code uses relative-accuracy preserving */ +/* > algorithms that might be (a bit) slower depending on the matrix. */ +/* > If the matrix does not define its eigenvalues to high relative */ +/* > accuracy, the code can uses possibly faster algorithms. */ +/* > If TRYRAC = .FALSE., the code is not required to guarantee */ +/* > relatively accurate eigenvalues and can use the fastest possible */ +/* > techniques. */ +/* > On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */ +/* > does not define its eigenvalues to high relative accuracy. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal */ +/* > (and minimal) LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,18*N) */ +/* > if JOBZ = 'V', and LWORK >= f2cmax(1,12*N) if JOBZ = 'N'. */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (LIWORK) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N) */ +/* > if the eigenvectors are desired, and LIWORK >= f2cmax(1,8*N) */ +/* > if only the eigenvalues are to be computed. */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, INFO */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = 1X, internal error in SLARRE, */ +/* > if INFO = 2X, internal error in CLARRV. */ +/* > Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ +/* > the nonzero error code returned by SLARRE or */ +/* > CLARRV, respectively. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int cstemr_(char *jobz, char *range, integer *n, real *d__, + real *e, real *vl, real *vu, integer *il, integer *iu, integer *m, + real *w, complex *z__, integer *ldz, integer *nzc, integer *isuppz, + logical *tryrac, real *work, integer *lwork, integer *iwork, integer * + liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + integer indd, iend, jblk, wend; + real rmin, rmax; + integer itmp; + real tnrm; + integer inde2; + extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *) + ; + integer itmp2; + real rtol1, rtol2; + integer i__, j; + real scale; + integer indgp; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer iindw, ilast; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer lwmin; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + logical wantz; + real r1, r2; + extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real * + , real *, real *); + integer jj; + real cs; + integer in; + logical alleig, indeig; + integer ibegin, iindbl; + real sn, wl; + logical valeig; + extern real slamch_(char *); + integer wbegin; + real safmin, wu; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + integer inderr, iindwk, indgrs, offset; + extern /* Subroutine */ int slarrc_(char *, integer *, real *, real *, + real *, real *, real *, integer *, integer *, integer *, integer * + ), clarrv_(integer *, real *, real *, real *, real *, + real *, integer *, integer *, integer *, integer *, real *, real * + , real *, real *, real *, real *, integer *, integer *, real *, + complex *, integer *, integer *, real *, integer *, integer *), + slarre_(char *, integer *, real *, real *, integer *, integer *, + real *, real *, real *, real *, real *, real *, integer *, + integer *, integer *, real *, real *, real *, integer *, integer * + , real *, real *, real *, integer *, integer *); + integer iinspl, indwrk, ifirst, liwmin, nzcmin; + real pivmin, thresh; + extern real slanst_(char *, integer *, real *, real *); + extern /* Subroutine */ int slarrj_(integer *, real *, real *, integer *, + integer *, real *, integer *, real *, real *, real *, integer *, + real *, real *, integer *); + integer nsplit; + extern /* Subroutine */ int slarrr_(integer *, real *, real *, integer *); + real smlnum; + extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); + logical lquery, zquery; + integer iil, iiu; + real eps, tmp; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; + zquery = *nzc == -1; +/* SSTEMR needs WORK of size 6*N, IWORK of size 3*N. */ +/* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N. */ +/* Furthermore, CLARRV needs WORK of size 12*N, IWORK of size 7*N. */ + if (wantz) { + lwmin = *n * 18; + liwmin = *n * 10; + } else { +/* need less workspace if only the eigenvalues are wanted */ + lwmin = *n * 12; + liwmin = *n << 3; + } + wl = 0.f; + wu = 0.f; + iil = 0; + iiu = 0; + nsplit = 0; + if (valeig) { +/* We do not reference VL, VU in the cases RANGE = 'I','A' */ +/* The interval (WL, WU] contains all the wanted eigenvalues. */ +/* It is either given by the user or computed in SLARRE. */ + wl = *vl; + wu = *vu; + } else if (indeig) { +/* We do not reference IL, IU in the cases RANGE = 'V','A' */ + iil = *il; + iiu = *iu; + } + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (valeig && *n > 0 && wu <= wl) { + *info = -7; + } else if (indeig && (iil < 1 || iil > *n)) { + *info = -8; + } else if (indeig && (iiu < iil || iiu > *n)) { + *info = -9; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -13; + } else if (*lwork < lwmin && ! lquery) { + *info = -17; + } else if (*liwork < liwmin && ! lquery) { + *info = -19; + } + +/* Get machine constants. */ + + safmin = slamch_("Safe minimum"); + eps = slamch_("Precision"); + smlnum = safmin / eps; + bignum = 1.f / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin)); + rmax = f2cmin(r__1,r__2); + + if (*info == 0) { + work[1] = (real) lwmin; + iwork[1] = liwmin; + + if (wantz && alleig) { + nzcmin = *n; + } else if (wantz && valeig) { + slarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & + itmp2, info); + } else if (wantz && indeig) { + nzcmin = iiu - iil + 1; + } else { +/* WANTZ .EQ. FALSE. */ + nzcmin = 0; + } + if (zquery && *info == 0) { + i__1 = z_dim1 + 1; + z__[i__1].r = (real) nzcmin, z__[i__1].i = 0.f; + } else if (*nzc < nzcmin && ! zquery) { + *info = -14; + } + } + if (*info != 0) { + + i__1 = -(*info); + xerbla_("CSTEMR", &i__1, (ftnlen)6); + + return 0; + } else if (lquery || zquery) { + return 0; + } + +/* Handle N = 0, 1, and 2 cases immediately */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = d__[1]; + } else { + if (wl < d__[1] && wu >= d__[1]) { + *m = 1; + w[1] = d__[1]; + } + } + if (wantz && ! zquery) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1.f, z__[i__1].i = 0.f; + isuppz[1] = 1; + isuppz[2] = 1; + } + return 0; + } + + if (*n == 2) { + if (! wantz) { + slae2_(&d__[1], &e[1], &d__[2], &r1, &r2); + } else if (wantz && ! zquery) { + slaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn); + } + if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) { + ++(*m); + w[*m] = r2; + if (wantz && ! zquery) { + i__1 = *m * z_dim1 + 1; + r__1 = -sn; + z__[i__1].r = r__1, z__[i__1].i = 0.f; + i__1 = *m * z_dim1 + 2; + z__[i__1].r = cs, z__[i__1].i = 0.f; +/* Note: At most one of SN and CS can be zero. */ + if (sn != 0.f) { + if (cs != 0.f) { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 2; + } else { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 1; + } + } else { + isuppz[(*m << 1) - 1] = 2; + isuppz[*m * 2] = 2; + } + } + } + if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) { + ++(*m); + w[*m] = r1; + if (wantz && ! zquery) { + i__1 = *m * z_dim1 + 1; + z__[i__1].r = cs, z__[i__1].i = 0.f; + i__1 = *m * z_dim1 + 2; + z__[i__1].r = sn, z__[i__1].i = 0.f; +/* Note: At most one of SN and CS can be zero. */ + if (sn != 0.f) { + if (cs != 0.f) { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 2; + } else { + isuppz[(*m << 1) - 1] = 1; + isuppz[*m * 2] = 1; + } + } else { + isuppz[(*m << 1) - 1] = 2; + isuppz[*m * 2] = 2; + } + } + } + } else { +/* Continue with general N */ + indgrs = 1; + inderr = (*n << 1) + 1; + indgp = *n * 3 + 1; + indd = (*n << 2) + 1; + inde2 = *n * 5 + 1; + indwrk = *n * 6 + 1; + + iinspl = 1; + iindbl = *n + 1; + iindw = (*n << 1) + 1; + iindwk = *n * 3 + 1; + +/* Scale matrix to allowable range, if necessary. */ +/* The allowable range is related to the PIVMIN parameter; see the */ +/* comments in SLARRD. The preference for scaling small values */ +/* up is heuristic; we expect users' matrices not to be close to the */ +/* RMAX threshold. */ + + scale = 1.f; + tnrm = slanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0.f && tnrm < rmin) { + scale = rmin / tnrm; + } else if (tnrm > rmax) { + scale = rmax / tnrm; + } + if (scale != 1.f) { + sscal_(n, &scale, &d__[1], &c__1); + i__1 = *n - 1; + sscal_(&i__1, &scale, &e[1], &c__1); + tnrm *= scale; + if (valeig) { +/* If eigenvalues in interval have to be found, */ +/* scale (WL, WU] accordingly */ + wl *= scale; + wu *= scale; + } + } + +/* Compute the desired eigenvalues of the tridiagonal after splitting */ +/* into smaller subblocks if the corresponding off-diagonal elements */ +/* are small */ +/* THRESH is the splitting parameter for SLARRE */ +/* A negative THRESH forces the old splitting criterion based on the */ +/* size of the off-diagonal. A positive THRESH switches to splitting */ +/* which preserves relative accuracy. */ + + if (*tryrac) { +/* Test whether the matrix warrants the more expensive relative approach. */ + slarrr_(n, &d__[1], &e[1], &iinfo); + } else { +/* The user does not care about relative accurately eigenvalues */ + iinfo = -1; + } +/* Set the splitting criterion */ + if (iinfo == 0) { + thresh = eps; + } else { + thresh = -eps; +/* relative accuracy is desired but T does not guarantee it */ + *tryrac = FALSE_; + } + + if (*tryrac) { +/* Copy original diagonal, needed to guarantee relative accuracy */ + scopy_(n, &d__[1], &c__1, &work[indd], &c__1); + } +/* Store the squares of the offdiagonal values of T */ + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing 2nd power */ + r__1 = e[j]; + work[inde2 + j - 1] = r__1 * r__1; +/* L5: */ + } +/* Set the tolerance parameters for bisection */ + if (! wantz) { +/* SLARRE computes the eigenvalues to full precision. */ + rtol1 = eps * 4.f; + rtol2 = eps * 4.f; + } else { +/* SLARRE computes the eigenvalues to less than full precision. */ +/* CLARRV will refine the eigenvalue approximations, and we only */ +/* need less accurate initial bisection in SLARRE. */ +/* Note: these settings do only affect the subset case and SLARRE */ +/* Computing MAX */ + r__1 = sqrt(eps) * .05f, r__2 = eps * 4.f; + rtol1 = f2cmax(r__1,r__2); +/* Computing MAX */ + r__1 = sqrt(eps) * .005f, r__2 = eps * 4.f; + rtol2 = f2cmax(r__1,r__2); + } + slarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], + &rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], & + work[inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], & + work[indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo); + if (iinfo != 0) { + *info = abs(iinfo) + 10; + return 0; + } +/* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired */ +/* part of the spectrum. All desired eigenvalues are contained in */ +/* (WL,WU] */ + if (wantz) { + +/* Compute the desired eigenvectors corresponding to the computed */ +/* eigenvalues */ + + clarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & + c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], & + work[indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], + &z__[z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[ + iindwk], &iinfo); + if (iinfo != 0) { + *info = abs(iinfo) + 20; + return 0; + } + } else { +/* SLARRE computes eigenvalues of the (shifted) root representation */ +/* CLARRV returns the eigenvalues of the unshifted matrix. */ +/* However, if the eigenvectors are not desired by the user, we need */ +/* to apply the corresponding shifts from SLARRE to obtain the */ +/* eigenvalues of the original matrix. */ + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + itmp = iwork[iindbl + j - 1]; + w[j] += e[iwork[iinspl + itmp - 1]]; +/* L20: */ + } + } + + if (*tryrac) { +/* Refine computed eigenvalues so that they are relatively accurate */ +/* with respect to the original matrix T. */ + ibegin = 1; + wbegin = 1; + i__1 = iwork[iindbl + *m - 1]; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = iwork[iinspl + jblk - 1]; + in = iend - ibegin + 1; + wend = wbegin - 1; +/* check if any eigenvalues have to be refined in this block */ +L36: + if (wend < *m) { + if (iwork[iindbl + wend] == jblk) { + ++wend; + goto L36; + } + } + if (wend < wbegin) { + ibegin = iend + 1; + goto L39; + } + offset = iwork[iindw + wbegin - 1] - 1; + ifirst = iwork[iindw + wbegin - 1]; + ilast = iwork[iindw + wend - 1]; + rtol2 = eps * 4.f; + slarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - + 1], &ifirst, &ilast, &rtol2, &offset, &w[wbegin], & + work[inderr + wbegin - 1], &work[indwrk], &iwork[ + iindwk], &pivmin, &tnrm, &iinfo); + ibegin = iend + 1; + wbegin = wend + 1; +L39: + ; + } + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (scale != 1.f) { + r__1 = 1.f / scale; + sscal_(m, &r__1, &w[1], &c__1); + } + } + +/* If eigenvalues are not in increasing order, then sort them, */ +/* possibly along with eigenvectors. */ + + if (nsplit > 1 || *n == 2) { + if (! wantz) { + slasrt_("I", m, &w[1], &iinfo); + if (iinfo != 0) { + *info = 3; + return 0; + } + } else { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp) { + i__ = jj; + tmp = w[jj]; + } +/* L50: */ + } + if (i__ != 0) { + w[i__] = w[j]; + w[j] = tmp; + if (wantz) { + cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * + z_dim1 + 1], &c__1); + itmp = isuppz[(i__ << 1) - 1]; + isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1]; + isuppz[(j << 1) - 1] = itmp; + itmp = isuppz[i__ * 2]; + isuppz[i__ * 2] = isuppz[j * 2]; + isuppz[j * 2] = itmp; + } + } +/* L60: */ + } + } + } + + + work[1] = (real) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of CSTEMR */ + +} /* cstemr_ */ + diff --git a/lapack-netlib/SRC/csteqr.c b/lapack-netlib/SRC/csteqr.c new file mode 100644 index 000000000..72f5d9c10 --- /dev/null +++ b/lapack-netlib/SRC/csteqr.c @@ -0,0 +1,1048 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSTEQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSTEQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) */ + +/* CHARACTER COMPZ */ +/* INTEGER INFO, LDZ, N */ +/* REAL D( * ), E( * ), WORK( * ) */ +/* COMPLEX Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSTEQR computes all eigenvalues and, optionally, eigenvectors of a */ +/* > symmetric tridiagonal matrix using the implicit QL or QR method. */ +/* > The eigenvectors of a full or band complex Hermitian matrix can also */ +/* > be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this */ +/* > matrix to tridiagonal form. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only. */ +/* > = 'V': Compute eigenvalues and eigenvectors of the original */ +/* > Hermitian matrix. On entry, Z must contain the */ +/* > unitary matrix used to reduce the original matrix */ +/* > to tridiagonal form. */ +/* > = 'I': Compute eigenvalues and eigenvectors of the */ +/* > tridiagonal matrix. Z is initialized to the identity */ +/* > matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the diagonal elements of the tridiagonal matrix. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', then Z contains the unitary */ +/* > matrix used in the reduction to tridiagonal form. */ +/* > On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ +/* > orthonormal eigenvectors of the original Hermitian matrix, */ +/* > and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ +/* > of the symmetric tridiagonal matrix. */ +/* > If COMPZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > eigenvectors are desired, then LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (f2cmax(1,2*N-2)) */ +/* > If COMPZ = 'N', then WORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: the algorithm has failed to find all the eigenvalues in */ +/* > a total of 30*N iterations; if INFO = i, then i */ +/* > elements of E have not converged to zero; on exit, D */ +/* > and E contain the elements of a symmetric tridiagonal */ +/* > matrix which is unitarily similar to the original */ +/* > matrix. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csteqr_(char *compz, integer *n, real *d__, real *e, + complex *z__, integer *ldz, real *work, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + integer lend, jtot; + extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *) + ; + real b, c__, f, g; + integer i__, j, k, l, m; + real p, r__, s; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int clasr_(char *, char *, char *, integer *, + integer *, real *, real *, complex *, integer *); + real anorm; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer l1, lendm1, lendp1; + extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real * + , real *, real *); + extern real slapy2_(real *, real *); + integer ii, mm, iscale; + extern real slamch_(char *); + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *); + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real safmax; + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *); + integer lendsv; + extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real * + ); + real ssfmin; + integer nmaxit, icompz; + real ssfmax; + extern real slanst_(char *, integer *, real *, real *); + extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); + integer lm1, mm1, nm1; + real rt1, rt2, eps; + integer lsv; + real tst, eps2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSTEQR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (icompz == 2) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1.f, z__[i__1].i = 0.f; + } + return 0; + } + +/* Determine the unit roundoff and over/underflow thresholds. */ + + eps = slamch_("E"); +/* Computing 2nd power */ + r__1 = eps; + eps2 = r__1 * r__1; + safmin = slamch_("S"); + safmax = 1.f / safmin; + ssfmax = sqrt(safmax) / 3.f; + ssfmin = sqrt(safmin) / eps2; + +/* Compute the eigenvalues and eigenvectors of the tridiagonal */ +/* matrix. */ + + if (icompz == 2) { + claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz); + } + + nmaxit = *n * 30; + jtot = 0; + +/* Determine where the matrix splits and choose QL or QR iteration */ +/* for each block, according to whether top or bottom diagonal */ +/* element is smaller. */ + + l1 = 1; + nm1 = *n - 1; + +L10: + if (l1 > *n) { + goto L160; + } + if (l1 > 1) { + e[l1 - 1] = 0.f; + } + if (l1 <= nm1) { + i__1 = nm1; + for (m = l1; m <= i__1; ++m) { + tst = (r__1 = e[m], abs(r__1)); + if (tst == 0.f) { + goto L30; + } + if (tst <= sqrt((r__1 = d__[m], abs(r__1))) * sqrt((r__2 = d__[m + + 1], abs(r__2))) * eps) { + e[m] = 0.f; + goto L30; + } +/* L20: */ + } + } + m = *n; + +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + +/* Scale submatrix in rows and columns L to LEND */ + + i__1 = lend - l + 1; + anorm = slanst_("I", &i__1, &d__[l], &e[l]); + iscale = 0; + if (anorm == 0.f) { + goto L10; + } + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info); + } + +/* Choose between QL and QR iteration */ + + if ((r__1 = d__[lend], abs(r__1)) < (r__2 = d__[l], abs(r__2))) { + lend = lsv; + l = lendsv; + } + + if (lend > l) { + +/* QL Iteration */ + +/* Look for small subdiagonal element. */ + +L40: + if (l != lend) { + lendm1 = lend - 1; + i__1 = lendm1; + for (m = l; m <= i__1; ++m) { +/* Computing 2nd power */ + r__2 = (r__1 = e[m], abs(r__1)); + tst = r__2 * r__2; + if (tst <= eps2 * (r__1 = d__[m], abs(r__1)) * (r__2 = d__[m + + 1], abs(r__2)) + safmin) { + goto L60; + } +/* L50: */ + } + } + + m = lend; + +L60: + if (m < lend) { + e[m] = 0.f; + } + p = d__[l]; + if (m == l) { + goto L80; + } + +/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */ +/* to compute its eigensystem. */ + + if (m == l + 1) { + if (icompz > 0) { + slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); + work[l] = c__; + work[*n - 1 + l] = s; + clasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & + z__[l * z_dim1 + 1], ldz); + } else { + slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); + } + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.f; + l += 2; + if (l <= lend) { + goto L40; + } + goto L140; + } + + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + +/* Form shift. */ + + g = (d__[l + 1] - p) / (e[l] * 2.f); + r__ = slapy2_(&g, &c_b41); + g = d__[m] - p + e[l] / (g + r_sign(&r__, &g)); + + s = 1.f; + c__ = 1.f; + p = 0.f; + +/* Inner loop */ + + mm1 = m - 1; + i__1 = l; + for (i__ = mm1; i__ >= i__1; --i__) { + f = s * e[i__]; + b = c__ * e[i__]; + slartg_(&g, &f, &c__, &s, &r__); + if (i__ != m - 1) { + e[i__ + 1] = r__; + } + g = d__[i__ + 1] - p; + r__ = (d__[i__] - g) * s + c__ * 2.f * b; + p = s * r__; + d__[i__ + 1] = g + p; + g = c__ * r__ - b; + +/* If eigenvectors are desired, then save rotations. */ + + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = -s; + } + +/* L70: */ + } + +/* If eigenvectors are desired, then apply saved rotations. */ + + if (icompz > 0) { + mm = m - l + 1; + clasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l + * z_dim1 + 1], ldz); + } + + d__[l] -= p; + e[l] = g; + goto L40; + +/* Eigenvalue found. */ + +L80: + d__[l] = p; + + ++l; + if (l <= lend) { + goto L40; + } + goto L140; + + } else { + +/* QR Iteration */ + +/* Look for small superdiagonal element. */ + +L90: + if (l != lend) { + lendp1 = lend + 1; + i__1 = lendp1; + for (m = l; m >= i__1; --m) { +/* Computing 2nd power */ + r__2 = (r__1 = e[m - 1], abs(r__1)); + tst = r__2 * r__2; + if (tst <= eps2 * (r__1 = d__[m], abs(r__1)) * (r__2 = d__[m + - 1], abs(r__2)) + safmin) { + goto L110; + } +/* L100: */ + } + } + + m = lend; + +L110: + if (m > lend) { + e[m - 1] = 0.f; + } + p = d__[l]; + if (m == l) { + goto L130; + } + +/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */ +/* to compute its eigensystem. */ + + if (m == l - 1) { + if (icompz > 0) { + slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) + ; + work[m] = c__; + work[*n - 1 + m] = s; + clasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & + z__[(l - 1) * z_dim1 + 1], ldz); + } else { + slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); + } + d__[l - 1] = rt1; + d__[l] = rt2; + e[l - 1] = 0.f; + l += -2; + if (l >= lend) { + goto L90; + } + goto L140; + } + + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + +/* Form shift. */ + + g = (d__[l - 1] - p) / (e[l - 1] * 2.f); + r__ = slapy2_(&g, &c_b41); + g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g)); + + s = 1.f; + c__ = 1.f; + p = 0.f; + +/* Inner loop */ + + lm1 = l - 1; + i__1 = lm1; + for (i__ = m; i__ <= i__1; ++i__) { + f = s * e[i__]; + b = c__ * e[i__]; + slartg_(&g, &f, &c__, &s, &r__); + if (i__ != m) { + e[i__ - 1] = r__; + } + g = d__[i__] - p; + r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b; + p = s * r__; + d__[i__] = g + p; + g = c__ * r__ - b; + +/* If eigenvectors are desired, then save rotations. */ + + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = s; + } + +/* L120: */ + } + +/* If eigenvectors are desired, then apply saved rotations. */ + + if (icompz > 0) { + mm = l - m + 1; + clasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m + * z_dim1 + 1], ldz); + } + + d__[l] -= p; + e[lm1] = g; + goto L90; + +/* Eigenvalue found. */ + +L130: + d__[l] = p; + + --l; + if (l >= lend) { + goto L90; + } + goto L140; + + } + +/* Undo scaling if necessary */ + +L140: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + i__1 = lendsv - lsv; + slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, + info); + } else if (iscale == 2) { + i__1 = lendsv - lsv + 1; + slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + i__1 = lendsv - lsv; + slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, + info); + } + +/* Check for no convergence to an eigenvalue after a total */ +/* of N*MAXIT iterations. */ + + if (jtot == nmaxit) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.f) { + ++(*info); + } +/* L150: */ + } + return 0; + } + goto L10; + +/* Order eigenvalues and eigenvectors. */ + +L160: + if (icompz == 0) { + +/* Use Quick Sort */ + + slasrt_("I", n, &d__[1], info); + + } else { + +/* Use Selection Sort to minimize swaps of eigenvectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } +/* L170: */ + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], + &c__1); + } +/* L180: */ + } + } + return 0; + +/* End of CSTEQR */ + +} /* csteqr_ */ + diff --git a/lapack-netlib/SRC/csycon.c b/lapack-netlib/SRC/csycon.c new file mode 100644 index 000000000..0e3055aa2 --- /dev/null +++ b/lapack-netlib/SRC/csycon.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 CSYCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL ANORM, RCOND */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYCON estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex symmetric matrix A using the factorization */ +/* > A = U*D*U**T or A = L*D*L**T computed by CSYTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csycon_(char *uplo, integer *n, complex *a, integer *lda, + integer *ipiv, real *anorm, real *rcond, complex *work, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer kase, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + real ainvnm; + extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex + *, integer *, integer *, complex *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*anorm < 0.f) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm <= 0.f) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (i__ = *n; i__ >= 1; --i__) { + i__1 = i__ + i__ * a_dim1; + if (ipiv[i__] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if (ipiv[i__] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { + return 0; + } +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + csytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n, + info); + goto L30; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + + return 0; + +/* End of CSYCON */ + +} /* csycon_ */ + diff --git a/lapack-netlib/SRC/csycon_3.c b/lapack-netlib/SRC/csycon_3.c new file mode 100644 index 000000000..8878496ba --- /dev/null +++ b/lapack-netlib/SRC/csycon_3.c @@ -0,0 +1,675 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYCON_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYCON_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, */ +/* WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL ANORM, RCOND */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E ( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CSYCON_3 estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex symmetric matrix A using the factorization */ +/* > computed by CSYTRF_RK or CSYTRF_BK: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > This routine uses BLAS3 solver CSYTRS_3. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix: */ +/* > = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); */ +/* > = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > Diagonal of the block diagonal matrix D and factors U or L */ +/* > as computed by CSYTRF_RK and CSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > should be provided on entry in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is not referenced in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSYTRF_RK or CSYTRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > June 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csycon_3_(char *uplo, integer *n, complex *a, integer * + lda, complex *e, integer *ipiv, real *anorm, real *rcond, complex * + work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer kase; + extern /* Subroutine */ int csytrs_3_(char *, integer *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + integer *); + integer i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + real ainvnm; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*anorm < 0.f) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYCON_3", &i__1, (ftnlen)8); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm <= 0.f) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (i__ = *n; i__ >= 1; --i__) { + i__1 = i__ + i__ * a_dim1; + if (ipiv[i__] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if (ipiv[i__] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { + return 0; + } + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + csytrs_3_(uplo, n, &c__1, &a[a_offset], lda, &e[1], &ipiv[1], &work[ + 1], n, info); + goto L30; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + + return 0; + +/* End of CSYCON_3 */ + +} /* csycon_3__ */ + diff --git a/lapack-netlib/SRC/csycon_rook.c b/lapack-netlib/SRC/csycon_rook.c new file mode 100644 index 000000000..75866a11c --- /dev/null +++ b/lapack-netlib/SRC/csycon_rook.c @@ -0,0 +1,647 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYCON_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYCON_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, */ +/* WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL ANORM, RCOND */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYCON_ROOK estimates the reciprocal of the condition number (in the */ +/* > 1-norm) of a complex symmetric matrix A using the factorization */ +/* > A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by CSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > The 1-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > April 2012, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csycon_rook_(char *uplo, integer *n, complex *a, + integer *lda, integer *ipiv, real *anorm, real *rcond, complex *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + extern /* Subroutine */ int csytrs_rook_(char *, integer *, integer *, + complex *, integer *, integer *, complex *, integer *, integer *); + integer kase, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + real ainvnm; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*anorm < 0.f) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYCON_ROOK", &i__1, (ftnlen)11); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm <= 0.f) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (i__ = *n; i__ >= 1; --i__) { + i__1 = i__ + i__ * a_dim1; + if (ipiv[i__] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if (ipiv[i__] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { + return 0; + } +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**T) or inv(U*D*U**T). */ + + csytrs_rook_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], + n, info); + goto L30; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + + return 0; + +/* End of CSYCON_ROOK */ + +} /* csycon_rook__ */ + diff --git a/lapack-netlib/SRC/csyconv.c b/lapack-netlib/SRC/csyconv.c new file mode 100644 index 000000000..00e86cc86 --- /dev/null +++ b/lapack-netlib/SRC/csyconv.c @@ -0,0 +1,811 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYCONV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYCONV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) */ + +/* CHARACTER UPLO, WAY */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYCONV convert A given by TRF into L and D and vice-versa. */ +/* > Get Non-diag elements of D (returned in workspace) and */ +/* > apply or reverse permutation done in TRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WAY */ +/* > \verbatim */ +/* > WAY is CHARACTER*1 */ +/* > = 'C': Convert */ +/* > = 'R': Revert */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N) */ +/* > E stores the supdiagonal/subdiagonal of the symmetric 1-by-1 */ +/* > or 2-by-2 block diagonal matrix D in LDLT. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csyconv_(char *uplo, char *way, integer *n, complex *a, + integer *lda, integer *ipiv, complex *e, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + complex temp; + integer i__, j; + extern logical lsame_(char *, char *); + logical upper; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical convert; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --e; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + convert = lsame_(way, "C"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! convert && ! lsame_(way, "R")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYCONV", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* A is UPPER */ + +/* Convert A (A is upper) */ + +/* Convert VALUE */ + + if (convert) { + i__ = *n; + e[1].r = 0.f, e[1].i = 0.f; + while(i__ > 1) { + if (ipiv[i__] < 0) { + i__1 = i__; + i__2 = i__ - 1 + i__ * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = i__ - 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = i__ - 1 + i__ * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + --i__; + } else { + i__1 = i__; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + --i__; + } + +/* Convert PERMUTATIONS */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = ip + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = ip + j * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = i__ + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L12: */ + } + } + } else { + ip = -ipiv[i__]; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = ip + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = ip + j * a_dim1; + i__3 = i__ - 1 + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = i__ - 1 + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L13: */ + } + } + --i__; + } + --i__; + } + } else { + +/* Revert A (A is upper) */ + + +/* Revert PERMUTATIONS */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = ip + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = ip + j * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = i__ + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + } + } + } else { + ip = -ipiv[i__]; + ++i__; + if (i__ < *n) { + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = ip + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = ip + j * a_dim1; + i__3 = i__ - 1 + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = i__ - 1 + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + } + } + } + ++i__; + } + +/* Revert VALUE */ + + i__ = *n; + while(i__ > 1) { + if (ipiv[i__] < 0) { + i__1 = i__ - 1 + i__ * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2].r, a[i__1].i = e[i__2].i; + --i__; + } + --i__; + } + } + } else { + +/* A is LOWER */ + + if (convert) { + +/* Convert A (A is lower) */ + + +/* Convert VALUE */ + + i__ = 1; + i__1 = *n; + e[i__1].r = 0.f, e[i__1].i = 0.f; + while(i__ <= *n) { + if (i__ < *n && ipiv[i__] < 0) { + i__1 = i__; + i__2 = i__ + 1 + i__ * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = i__ + 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = i__ + 1 + i__ * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + ++i__; + } else { + i__1 = i__; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + ++i__; + } + +/* Convert PERMUTATIONS */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = ip + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = ip + j * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = i__ + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L22: */ + } + } + } else { + ip = -ipiv[i__]; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = ip + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = ip + j * a_dim1; + i__3 = i__ + 1 + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = i__ + 1 + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L23: */ + } + } + ++i__; + } + ++i__; + } + } else { + +/* Revert A (A is lower) */ + + +/* Revert PERMUTATIONS */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + j * a_dim1; + i__3 = ip + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = ip + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + } + } + } else { + ip = -ipiv[i__]; + --i__; + if (i__ > 1) { + i__1 = i__ - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + 1 + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + 1 + j * a_dim1; + i__3 = ip + j * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = ip + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + } + } + } + --i__; + } + +/* Revert VALUE */ + + i__ = 1; + while(i__ <= *n - 1) { + if (ipiv[i__] < 0) { + i__1 = i__ + 1 + i__ * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2].r, a[i__1].i = e[i__2].i; + ++i__; + } + ++i__; + } + } + } + return 0; + +/* End of CSYCONV */ + +} /* csyconv_ */ + diff --git a/lapack-netlib/SRC/csyconvf.c b/lapack-netlib/SRC/csyconvf.c new file mode 100644 index 000000000..fe327e691 --- /dev/null +++ b/lapack-netlib/SRC/csyconvf.c @@ -0,0 +1,974 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYCONVF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYCONVF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) */ + +/* CHARACTER UPLO, WAY */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > If parameter WAY = 'C': */ +/* > CSYCONVF converts the factorization output format used in */ +/* > CSYTRF provided on entry in parameter A into the factorization */ +/* > output format used in CSYTRF_RK (or CSYTRF_BK) that is stored */ +/* > on exit in parameters A and E. It also coverts in place details of */ +/* > the intechanges stored in IPIV from the format used in CSYTRF into */ +/* > the format used in CSYTRF_RK (or CSYTRF_BK). */ +/* > */ +/* > If parameter WAY = 'R': */ +/* > CSYCONVF performs the conversion in reverse direction, i.e. */ +/* > converts the factorization output format used in CSYTRF_RK */ +/* > (or CSYTRF_BK) provided on entry in parameters A and E into */ +/* > the factorization output format used in CSYTRF that is stored */ +/* > on exit in parameter A. It also coverts in place details of */ +/* > the intechanges stored in IPIV from the format used in CSYTRF_RK */ +/* > (or CSYTRF_BK) into the format used in CSYTRF. */ +/* > */ +/* > CSYCONVF can also convert in Hermitian matrix case, i.e. between */ +/* > formats used in CHETRF and CHETRF_RK (or CHETRF_BK). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix A. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WAY */ +/* > \verbatim */ +/* > WAY is CHARACTER*1 */ +/* > = 'C': Convert */ +/* > = 'R': Revert */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > CSYTRF: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal part of A. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > CSYTRF_RK or CSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > CSYTRF_RK or CSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > CSYTRF: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, just a workspace. */ +/* > */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > On exit, is not changed */ +/* > \endverbatim */ +/* . */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > On entry, details of the interchanges and the block */ +/* > structure of D in the format used in CSYTRF. */ +/* > On exit, details of the interchanges and the block */ +/* > structure of D in the format used in CSYTRF_RK */ +/* > ( or CSYTRF_BK). */ +/* > */ +/* > 1) If WAY ='R': */ +/* > On entry, details of the interchanges and the block */ +/* > structure of D in the format used in CSYTRF_RK */ +/* > ( or CSYTRF_BK). */ +/* > On exit, details of the interchanges and the block */ +/* > structure of D in the format used in CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ +/* ===================================================================== */ +/* Subroutine */ int csyconvf_(char *uplo, char *way, integer *n, complex *a, + integer *lda, complex *e, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + logical upper; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical convert; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + convert = lsame_(way, "C"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! convert && ! lsame_(way, "R")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYCONVF", &i__1, (ftnlen)8); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Begin A is UPPER */ + + if (convert) { + +/* Convert A (A is upper) */ + + +/* Convert VALUE */ + +/* Assign superdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = *n; + e[1].r = 0.f, e[1].i = 0.f; + while(i__ > 1) { + if (ipiv[i__] < 0) { + i__1 = i__; + i__2 = i__ - 1 + i__ * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = i__ - 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = i__ - 1 + i__ * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + --i__; + } else { + i__1 = i__; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + --i__; + } + +/* Convert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of upper part of A */ +/* in factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + cswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, & + a[ip + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) */ + + ip = -ipiv[i__]; + if (i__ < *n) { + if (ip != i__ - 1) { + i__1 = *n - i__; + cswap_(&i__1, &a[i__ - 1 + (i__ + 1) * a_dim1], + lda, &a[ip + (i__ + 1) * a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is no interchnge of rows i and and IPIV(i), */ +/* so this should be reflected in IPIV format for */ +/* *SYTRF_RK ( or *SYTRF_BK) */ + + ipiv[i__] = i__; + + --i__; + + } + --i__; + } + + } else { + +/* Revert A (A is upper) */ + + +/* Revert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of upper part of A */ +/* in reverse factorization order where i increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + cswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) */ + + ++i__; + ip = -ipiv[i__]; + if (i__ < *n) { + if (ip != i__ - 1) { + i__1 = *n - i__; + cswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ - 1 + (i__ + 1) * a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is one interchange of rows i-1 and IPIV(i-1), */ +/* so this should be recorded in two consecutive entries */ +/* in IPIV format for *SYTRF */ + + ipiv[i__] = ipiv[i__ - 1]; + + } + ++i__; + } + +/* Revert VALUE */ +/* Assign superdiagonal entries of D from array E to */ +/* superdiagonal entries of A. */ + + i__ = *n; + while(i__ > 1) { + if (ipiv[i__] < 0) { + i__1 = i__ - 1 + i__ * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2].r, a[i__1].i = e[i__2].i; + --i__; + } + --i__; + } + +/* End A is UPPER */ + + } + + } else { + +/* Begin A is LOWER */ + + if (convert) { + +/* Convert A (A is lower) */ + + +/* Convert VALUE */ +/* Assign subdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = 1; + i__1 = *n; + e[i__1].r = 0.f, e[i__1].i = 0.f; + while(i__ <= *n) { + if (i__ < *n && ipiv[i__] < 0) { + i__1 = i__; + i__2 = i__ + 1 + i__ * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = i__ + 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = i__ + 1 + i__ * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + ++i__; + } else { + i__1 = i__; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + ++i__; + } + +/* Convert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of lower part of A */ +/* in factorization order where k increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + cswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) */ + + ip = -ipiv[i__]; + if (i__ > 1) { + if (ip != i__ + 1) { + i__1 = i__ - 1; + cswap_(&i__1, &a[i__ + 1 + a_dim1], lda, &a[ip + + a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is no interchnge of rows i and and IPIV(i), */ +/* so this should be reflected in IPIV format for */ +/* *SYTRF_RK ( or *SYTRF_BK) */ + + ipiv[i__] = i__; + + ++i__; + + } + ++i__; + } + + } else { + +/* Revert A (A is lower) */ + + +/* Revert PERMUTATIONS and IPIV */ + +/* Apply permutations to submatrices of lower part of A */ +/* in reverse factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + cswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) */ + + --i__; + ip = -ipiv[i__]; + if (i__ > 1) { + if (ip != i__ + 1) { + i__1 = i__ - 1; + cswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + 1 + + a_dim1], lda); + } + } + +/* Convert IPIV */ +/* There is one interchange of rows i+1 and IPIV(i+1), */ +/* so this should be recorded in consecutive entries */ +/* in IPIV format for *SYTRF */ + + ipiv[i__] = ipiv[i__ + 1]; + + } + --i__; + } + +/* Revert VALUE */ +/* Assign subdiagonal entries of D from array E to */ +/* subgiagonal entries of A. */ + + i__ = 1; + while(i__ <= *n - 1) { + if (ipiv[i__] < 0) { + i__1 = i__ + 1 + i__ * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2].r, a[i__1].i = e[i__2].i; + ++i__; + } + ++i__; + } + + } + +/* End A is LOWER */ + + } + return 0; + +/* End of CSYCONVF */ + +} /* csyconvf_ */ + diff --git a/lapack-netlib/SRC/csyconvf_rook.c b/lapack-netlib/SRC/csyconvf_rook.c new file mode 100644 index 000000000..1e5c22d33 --- /dev/null +++ b/lapack-netlib/SRC/csyconvf_rook.c @@ -0,0 +1,964 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYCONVF_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYCONVF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) */ + +/* CHARACTER UPLO, WAY */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > If parameter WAY = 'C': */ +/* > CSYCONVF_ROOK converts the factorization output format used in */ +/* > CSYTRF_ROOK provided on entry in parameter A into the factorization */ +/* > output format used in CSYTRF_RK (or CSYTRF_BK) that is stored */ +/* > on exit in parameters A and E. IPIV format for CSYTRF_ROOK and */ +/* > CSYTRF_RK (or CSYTRF_BK) is the same and is not converted. */ +/* > */ +/* > If parameter WAY = 'R': */ +/* > CSYCONVF_ROOK performs the conversion in reverse direction, i.e. */ +/* > converts the factorization output format used in CSYTRF_RK */ +/* > (or CSYTRF_BK) provided on entry in parameters A and E into */ +/* > the factorization output format used in CSYTRF_ROOK that is stored */ +/* > on exit in parameter A. IPIV format for CSYTRF_ROOK and */ +/* > CSYTRF_RK (or CSYTRF_BK) is the same and is not converted. */ +/* > */ +/* > CSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between */ +/* > formats used in CHETRF_ROOK and CHETRF_RK (or CHETRF_BK). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix A. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WAY */ +/* > \verbatim */ +/* > WAY is CHARACTER*1 */ +/* > = 'C': Convert */ +/* > = 'R': Revert */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > CSYTRF_ROOK: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal part of A. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > CSYTRF_RK or CSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains factorization details in format used in */ +/* > CSYTRF_RK or CSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > On exit, contains factorization details in format used in */ +/* > CSYTRF_ROOK: */ +/* > a) all elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A and on superdiagonal */ +/* > (or subdiagonal) of A, and */ +/* > b) If UPLO = 'U': multipliers used to obtain factor U */ +/* > in the superdiagonal part of A. */ +/* > If UPLO = 'L': multipliers used to obtain factor L */ +/* > in the superdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N) */ +/* > */ +/* > 1) If WAY ='C': */ +/* > */ +/* > On entry, just a workspace. */ +/* > */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > 2) If WAY = 'R': */ +/* > */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > On exit, is not changed */ +/* > \endverbatim */ +/* . */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > On entry, details of the interchanges and the block */ +/* > structure of D as determined: */ +/* > 1) by CSYTRF_ROOK, if WAY ='C'; */ +/* > 2) by CSYTRF_RK (or CSYTRF_BK), if WAY ='R'. */ +/* > The IPIV format is the same for all these routines. */ +/* > */ +/* > On exit, is not changed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ +/* ===================================================================== */ +/* Subroutine */ int csyconvf_rook_(char *uplo, char *way, integer *n, + complex *a, integer *lda, complex *e, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + logical upper; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer ip2; + logical convert; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + convert = lsame_(way, "C"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! convert && ! lsame_(way, "R")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYCONVF_ROOK", &i__1, (ftnlen)13); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Begin A is UPPER */ + + if (convert) { + +/* Convert A (A is upper) */ + + +/* Convert VALUE */ + +/* Assign superdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = *n; + e[1].r = 0.f, e[1].i = 0.f; + while(i__ > 1) { + if (ipiv[i__] < 0) { + i__1 = i__; + i__2 = i__ - 1 + i__ * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = i__ - 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = i__ - 1 + i__ * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + --i__; + } else { + i__1 = i__; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + --i__; + } + +/* Convert PERMUTATIONS */ + +/* Apply permutations to submatrices of upper part of A */ +/* in factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + cswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, & + a[ip + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i and IPIV(i) and i-1 and IPIV(i-1) */ +/* in A(1:i,N-i:N) */ + + ip = -ipiv[i__]; + ip2 = -ipiv[i__ - 1]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + cswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, & + a[ip + (i__ + 1) * a_dim1], lda); + } + if (ip2 != i__ - 1) { + i__1 = *n - i__; + cswap_(&i__1, &a[i__ - 1 + (i__ + 1) * a_dim1], + lda, &a[ip2 + (i__ + 1) * a_dim1], lda); + } + } + --i__; + + } + --i__; + } + + } else { + +/* Revert A (A is upper) */ + + +/* Revert PERMUTATIONS */ + +/* Apply permutations to submatrices of upper part of A */ +/* in reverse factorization order where i increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(1:i,N-i:N) */ + + ip = ipiv[i__]; + if (i__ < *n) { + if (ip != i__) { + i__1 = *n - i__; + cswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ + (i__ + 1) * a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i-1 and IPIV(i-1) and i and IPIV(i) */ +/* in A(1:i,N-i:N) */ + + ++i__; + ip = -ipiv[i__]; + ip2 = -ipiv[i__ - 1]; + if (i__ < *n) { + if (ip2 != i__ - 1) { + i__1 = *n - i__; + cswap_(&i__1, &a[ip2 + (i__ + 1) * a_dim1], lda, & + a[i__ - 1 + (i__ + 1) * a_dim1], lda); + } + if (ip != i__) { + i__1 = *n - i__; + cswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, & + a[i__ + (i__ + 1) * a_dim1], lda); + } + } + + } + ++i__; + } + +/* Revert VALUE */ +/* Assign superdiagonal entries of D from array E to */ +/* superdiagonal entries of A. */ + + i__ = *n; + while(i__ > 1) { + if (ipiv[i__] < 0) { + i__1 = i__ - 1 + i__ * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2].r, a[i__1].i = e[i__2].i; + --i__; + } + --i__; + } + +/* End A is UPPER */ + + } + + } else { + +/* Begin A is LOWER */ + + if (convert) { + +/* Convert A (A is lower) */ + + +/* Convert VALUE */ +/* Assign subdiagonal entries of D to array E and zero out */ +/* corresponding entries in input storage A */ + + i__ = 1; + i__1 = *n; + e[i__1].r = 0.f, e[i__1].i = 0.f; + while(i__ <= *n) { + if (i__ < *n && ipiv[i__] < 0) { + i__1 = i__; + i__2 = i__ + 1 + i__ * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = i__ + 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = i__ + 1 + i__ * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + ++i__; + } else { + i__1 = i__; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + ++i__; + } + +/* Convert PERMUTATIONS */ + +/* Apply permutations to submatrices of lower part of A */ +/* in factorization order where i increases from 1 to N */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + cswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i and IPIV(i) and i+1 and IPIV(i+1) */ +/* in A(i:N,1:i-1) */ + + ip = -ipiv[i__]; + ip2 = -ipiv[i__ + 1]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + cswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + + a_dim1], lda); + } + if (ip2 != i__ + 1) { + i__1 = i__ - 1; + cswap_(&i__1, &a[i__ + 1 + a_dim1], lda, &a[ip2 + + a_dim1], lda); + } + } + ++i__; + + } + ++i__; + } + + } else { + +/* Revert A (A is lower) */ + + +/* Revert PERMUTATIONS */ + +/* Apply permutations to submatrices of lower part of A */ +/* in reverse factorization order where i decreases from N to 1 */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + +/* 1-by-1 pivot interchange */ + +/* Swap rows i and IPIV(i) in A(i:N,1:i-1) */ + + ip = ipiv[i__]; + if (i__ > 1) { + if (ip != i__) { + i__1 = i__ - 1; + cswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + + a_dim1], lda); + } + } + + } else { + +/* 2-by-2 pivot interchange */ + +/* Swap rows i+1 and IPIV(i+1) and i and IPIV(i) */ +/* in A(i:N,1:i-1) */ + + --i__; + ip = -ipiv[i__]; + ip2 = -ipiv[i__ + 1]; + if (i__ > 1) { + if (ip2 != i__ + 1) { + i__1 = i__ - 1; + cswap_(&i__1, &a[ip2 + a_dim1], lda, &a[i__ + 1 + + a_dim1], lda); + } + if (ip != i__) { + i__1 = i__ - 1; + cswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + + a_dim1], lda); + } + } + + } + --i__; + } + +/* Revert VALUE */ +/* Assign subdiagonal entries of D from array E to */ +/* subgiagonal entries of A. */ + + i__ = 1; + while(i__ <= *n - 1) { + if (ipiv[i__] < 0) { + i__1 = i__ + 1 + i__ * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2].r, a[i__1].i = e[i__2].i; + ++i__; + } + ++i__; + } + + } + +/* End A is LOWER */ + + } + return 0; + +/* End of CSYCONVF_ROOK */ + +} /* csyconvf_rook__ */ + diff --git a/lapack-netlib/SRC/csyequb.c b/lapack-netlib/SRC/csyequb.c new file mode 100644 index 000000000..ef6a04ed6 --- /dev/null +++ b/lapack-netlib/SRC/csyequb.c @@ -0,0 +1,873 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYEQUB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYEQUB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* REAL AMAX, SCOND */ +/* CHARACTER UPLO */ +/* COMPLEX A( LDA, * ), WORK( * ) */ +/* REAL S( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYEQUB computes row and column scalings intended to equilibrate a */ +/* > symmetric matrix A (with respect to the Euclidean norm) and reduce */ +/* > its condition number. The scale factors S are computed by the BIN */ +/* > algorithm (see references) so that the scaled matrix B with elements */ +/* > B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of */ +/* > the smallest possible condition number over all possible diagonal */ +/* > scalings. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The N-by-N symmetric matrix whose scaling factors are to be */ +/* > computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > If INFO = 0, S contains the scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* > the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* > large nor too small, it is not worth scaling by S. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Largest absolute value of any matrix element. If AMAX is */ +/* > very close to overflow or very close to underflow, the */ +/* > matrix should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element is nonpositive. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n */ +/* > Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n */ +/* > DOI 10.1023/B:NUMA.0000016606.32820.69 \n */ +/* > Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int csyequb_(char *uplo, integer *n, complex *a, integer * + lda, real *s, real *scond, real *amax, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + doublereal d__1; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + real base; + integer iter; + real smin, smax, d__; + integer i__, j; + real t, u, scale; + extern logical lsame_(char *, char *); + real c0, c1, c2, sumsq, si; + logical up; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + extern /* Subroutine */ int classq_(integer *, complex *, integer *, real + *, real *); + real smlnum, avg, std, tol; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --s; + --work; + + /* Function Body */ + *info = 0; + if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYEQUB", &i__1, (ftnlen)7); + return 0; + } + up = lsame_(uplo, "U"); + *amax = 0.f; + +/* Quick return if possible. */ + + if (*n == 0) { + *scond = 1.f; + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 0.f; + } + *amax = 0.f; + if (up) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + r__3 = s[i__], r__4 = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + j * a_dim1]), abs(r__2)); + s[i__] = f2cmax(r__3,r__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + r__3 = s[j], r__4 = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + j * a_dim1]), abs(r__2)); + s[j] = f2cmax(r__3,r__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + r__3 = *amax, r__4 = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + j * a_dim1]), abs(r__2)); + *amax = f2cmax(r__3,r__4); + } +/* Computing MAX */ + i__2 = j + j * a_dim1; + r__3 = s[j], r__4 = (r__1 = a[i__2].r, abs(r__1)) + (r__2 = + r_imag(&a[j + j * a_dim1]), abs(r__2)); + s[j] = f2cmax(r__3,r__4); +/* Computing MAX */ + i__2 = j + j * a_dim1; + r__3 = *amax, r__4 = (r__1 = a[i__2].r, abs(r__1)) + (r__2 = + r_imag(&a[j + j * a_dim1]), abs(r__2)); + *amax = f2cmax(r__3,r__4); + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j + j * a_dim1; + r__3 = s[j], r__4 = (r__1 = a[i__2].r, abs(r__1)) + (r__2 = + r_imag(&a[j + j * a_dim1]), abs(r__2)); + s[j] = f2cmax(r__3,r__4); +/* Computing MAX */ + i__2 = j + j * a_dim1; + r__3 = *amax, r__4 = (r__1 = a[i__2].r, abs(r__1)) + (r__2 = + r_imag(&a[j + j * a_dim1]), abs(r__2)); + *amax = f2cmax(r__3,r__4); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + r__3 = s[i__], r__4 = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + j * a_dim1]), abs(r__2)); + s[i__] = f2cmax(r__3,r__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + r__3 = s[j], r__4 = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + j * a_dim1]), abs(r__2)); + s[j] = f2cmax(r__3,r__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + r__3 = *amax, r__4 = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + j * a_dim1]), abs(r__2)); + *amax = f2cmax(r__3,r__4); + } + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + s[j] = 1.f / s[j]; + } + tol = 1.f / sqrt(*n * 2.f); + for (iter = 1; iter <= 100; ++iter) { + scale = 0.f; + sumsq = 0.f; +/* beta = |A|s */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + work[i__2].r = 0.f, work[i__2].i = 0.f; + } + if (up) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + r__3 = ((r__1 = a[i__5].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + j * a_dim1]), abs(r__2))) * s[j]; + q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + i__3 = j; + i__4 = j; + i__5 = i__ + j * a_dim1; + r__3 = ((r__1 = a[i__5].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + j * a_dim1]), abs(r__2))) * s[i__]; + q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + r__3 = ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag(&a[j + + j * a_dim1]), abs(r__2))) * s[j]; + q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + r__3 = ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag(&a[j + + j * a_dim1]), abs(r__2))) * s[j]; + q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + r__3 = ((r__1 = a[i__5].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + j * a_dim1]), abs(r__2))) * s[j]; + q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + i__3 = j; + i__4 = j; + i__5 = i__ + j * a_dim1; + r__3 = ((r__1 = a[i__5].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + j * a_dim1]), abs(r__2))) * s[i__]; + q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + } +/* avg = s^T beta / n */ + avg = 0.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__2.r = s[i__2] * work[i__3].r, q__2.i = s[i__2] * work[i__3].i; + q__1.r = avg + q__2.r, q__1.i = q__2.i; + avg = q__1.r; + } + avg /= *n; + std = 0.f; + i__1 = *n << 1; + for (i__ = *n + 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__ - *n; + i__4 = i__ - *n; + q__2.r = s[i__3] * work[i__4].r, q__2.i = s[i__3] * work[i__4].i; + q__1.r = q__2.r - avg, q__1.i = q__2.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + classq_(n, &work[*n + 1], &c__1, &scale, &sumsq); + std = scale * sqrt(sumsq / *n); + if (std < tol * avg) { + goto L999; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + t = (r__1 = a[i__2].r, abs(r__1)) + (r__2 = r_imag(&a[i__ + i__ * + a_dim1]), abs(r__2)); + si = s[i__]; + c2 = (*n - 1) * t; + i__2 = *n - 2; + i__3 = i__; + r__1 = t * si; + q__2.r = work[i__3].r - r__1, q__2.i = work[i__3].i; + d__1 = (doublereal) i__2; + q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i; + c1 = q__1.r; + r__1 = -(t * si) * si; + i__2 = i__; + d__1 = 2.; + q__4.r = d__1 * work[i__2].r, q__4.i = d__1 * work[i__2].i; + q__3.r = si * q__4.r, q__3.i = si * q__4.i; + q__2.r = r__1 + q__3.r, q__2.i = q__3.i; + r__2 = *n * avg; + q__1.r = q__2.r - r__2, q__1.i = q__2.i; + c0 = q__1.r; + d__ = c1 * c1 - c0 * 4 * c2; + if (d__ <= 0.f) { + *info = -1; + return 0; + } + si = c0 * -2 / (c1 + sqrt(d__)); + d__ = si - s[i__]; + u = 0.f; + if (up) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + t = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag(&a[j + + i__ * a_dim1]), abs(r__2)); + u += s[j] * t; + i__3 = j; + i__4 = j; + r__1 = d__ * t; + q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + t = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag(&a[i__ + + j * a_dim1]), abs(r__2)); + u += s[j] * t; + i__3 = j; + i__4 = j; + r__1 = d__ * t; + q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + t = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag(&a[i__ + + j * a_dim1]), abs(r__2)); + u += s[j] * t; + i__3 = j; + i__4 = j; + r__1 = d__ * t; + q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + t = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag(&a[j + + i__ * a_dim1]), abs(r__2)); + u += s[j] * t; + i__3 = j; + i__4 = j; + r__1 = d__ * t; + q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + i__2 = i__; + q__4.r = u + work[i__2].r, q__4.i = work[i__2].i; + q__3.r = d__ * q__4.r, q__3.i = d__ * q__4.i; + d__1 = (doublereal) (*n); + q__2.r = q__3.r / d__1, q__2.i = q__3.i / d__1; + q__1.r = avg + q__2.r, q__1.i = q__2.i; + avg = q__1.r; + s[i__] = si; + } + } +L999: + smlnum = slamch_("SAFEMIN"); + bignum = 1.f / smlnum; + smin = bignum; + smax = 0.f; + t = 1.f / sqrt(avg); + base = slamch_("B"); + u = 1.f / log(base); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = (integer) (u * log(s[i__] * t)); + s[i__] = pow_ri(&base, &i__2); +/* Computing MIN */ + r__1 = smin, r__2 = s[i__]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = smax, r__2 = s[i__]; + smax = f2cmax(r__1,r__2); + } + *scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + + return 0; +} /* csyequb_ */ + diff --git a/lapack-netlib/SRC/csymv.c b/lapack-netlib/SRC/csymv.c new file mode 100644 index 000000000..7fae93054 --- /dev/null +++ b/lapack-netlib/SRC/csymv.c @@ -0,0 +1,868 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYMV computes a matrix-vector product for a complex symmetric matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) */ + +/* CHARACTER UPLO */ +/* INTEGER INCX, INCY, LDA, N */ +/* COMPLEX ALPHA, BETA */ +/* COMPLEX A( LDA, * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYMV performs the matrix-vector operation */ +/* > */ +/* > y := alpha*A*x + beta*y, */ +/* > */ +/* > where alpha and beta are scalars, x and y are n element vectors and */ +/* > A is an n by n symmetric matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the array A is to be referenced as */ +/* > follows: */ +/* > */ +/* > UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > UPLO = 'L' or 'l' 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 order of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > Before entry, with UPLO = 'U' or 'u', the leading n by n */ +/* > upper triangular part of the array A must contain the upper */ +/* > triangular part of the symmetric matrix and the strictly */ +/* > lower triangular part of A is not referenced. */ +/* > Before entry, with UPLO = 'L' or 'l', the leading n by n */ +/* > lower triangular part of the array A must contain the lower */ +/* > triangular part of the symmetric matrix and the strictly */ +/* > upper triangular part of A is not referenced. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > On entry, LDA specifies the first dimension of A as declared */ +/* > in the calling (sub) program. LDA must be at least */ +/* > f2cmax( 1, N ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension at least */ +/* > ( 1 + ( N - 1 )*abs( INCX ) ). */ +/* > Before entry, the incremented array X must contain the N- */ +/* > element 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 COMPLEX */ +/* > 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 COMPLEX array, dimension at least */ +/* > ( 1 + ( N - 1 )*abs( INCY ) ). */ +/* > Before entry, the incremented array Y must contain the n */ +/* > element 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 December 2016 */ + +/* > \ingroup complexSYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int csymv_(char *uplo, integer *n, complex *alpha, complex * + a, integer *lda, complex *x, integer *incx, complex *beta, complex *y, + integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer info; + complex temp1, temp2; + integer i__, j; + extern logical lsame_(char *, char *); + integer ix, iy, jx, jy, kx, ky; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* 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 (! lsame_(uplo, "U") && ! lsame_(uplo, "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_("CSYMV ", &info, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && + beta->i == 0.f)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1.f || beta->i != 0.f) { + if (*incy == 1) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0.f, y[i__2].i = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0.f, y[i__2].i = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when A is stored in upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = i__ + j * a_dim1; + i__4 = i__; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L50: */ + } + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + q__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__3.i = + temp1.r * a[i__4].i + temp1.i * a[i__4].r; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = i__ + j * a_dim1; + i__4 = ix; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + q__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__3.i = + temp1.r * a[i__4].i + temp1.i * a[i__4].r; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } else { + +/* Form y when A is stored in lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + q__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__2.i = + temp1.r * a[i__4].i + temp1.i * a[i__4].r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = i__ + j * a_dim1; + i__4 = i__; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L90: */ + } + i__2 = j; + i__3 = j; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + q__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__2.i = + temp1.r * a[i__4].i + temp1.i * a[i__4].r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + i__3 = i__ + j * a_dim1; + i__4 = ix; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[ + i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L110: */ + } + i__2 = jy; + i__3 = jy; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of CSYMV */ + +} /* csymv_ */ + diff --git a/lapack-netlib/SRC/csyr.c b/lapack-netlib/SRC/csyr.c new file mode 100644 index 000000000..c4822edc4 --- /dev/null +++ b/lapack-netlib/SRC/csyr.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 CSYR performs the symmetric rank-1 update of a complex symmetric matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) */ + +/* CHARACTER UPLO */ +/* INTEGER INCX, LDA, N */ +/* COMPLEX ALPHA */ +/* COMPLEX A( LDA, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYR performs the symmetric rank 1 operation */ +/* > */ +/* > A := alpha*x*x**H + A, */ +/* > */ +/* > where alpha is a complex scalar, x is an n element vector and A is an */ +/* > n by n symmetric matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the array A is to be referenced as */ +/* > follows: */ +/* > */ +/* > UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > UPLO = 'L' or 'l' 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 order of the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension at least */ +/* > ( 1 + ( N - 1 )*abs( INCX ) ). */ +/* > Before entry, the incremented array X must contain the N- */ +/* > element 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,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > Before entry, with UPLO = 'U' or 'u', the leading n by n */ +/* > upper triangular part of the array A must contain the upper */ +/* > triangular part of the symmetric matrix and the strictly */ +/* > lower triangular part of A is not referenced. On exit, the */ +/* > upper triangular part of the array A is overwritten by the */ +/* > upper triangular part of the updated matrix. */ +/* > Before entry, with UPLO = 'L' or 'l', the leading n by n */ +/* > lower triangular part of the array A must contain the lower */ +/* > triangular part of the symmetric matrix and the strictly */ +/* > upper triangular part of A is not referenced. On exit, the */ +/* > lower triangular part of the array A is overwritten by the */ +/* > lower triangular part of the updated matrix. */ +/* > \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 */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int csyr_(char *uplo, integer *n, complex *alpha, complex *x, + integer *incx, complex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2; + + /* Local variables */ + integer info; + complex temp; + integer i__, j; + extern logical lsame_(char *, char *); + integer ix, jx, kx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*lda < f2cmax(1,*n)) { + info = 7; + } + if (info != 0) { + xerbla_("CSYR ", &info, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in upper triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + ix = kx; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + } + jx += *incx; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in lower triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + ix = jx; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + + return 0; + +/* End of CSYR */ + +} /* csyr_ */ + diff --git a/lapack-netlib/SRC/csyrfs.c b/lapack-netlib/SRC/csyrfs.c new file mode 100644 index 000000000..42cdfcf24 --- /dev/null +++ b/lapack-netlib/SRC/csyrfs.c @@ -0,0 +1,926 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, */ +/* X, LDX, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is symmetric indefinite, and */ +/* > provides error bounds and backward error estimates for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular part */ +/* > of the matrix A, and the strictly lower triangular part of A */ +/* > is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of A contains the lower triangular part of */ +/* > the matrix A, and the strictly upper triangular part of A is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX array, dimension (LDAF,N) */ +/* > The factored form of the matrix A. AF contains the block */ +/* > diagonal matrix D and the multipliers used to obtain the */ +/* > factor U or L from the factorization A = U*D*U**T or */ +/* > A = L*D*L**T as computed by CSYTRF. */ +/* > \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 CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by CSYTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \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 complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csyrfs_(char *uplo, integer *n, integer *nrhs, complex * + a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex * + b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, + complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + complex q__1; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + integer count; + logical upper; + extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex * + , integer *, complex *, integer *, complex *, complex *, integer * + ), clacn2_(integer *, complex *, complex *, real *, + integer *, integer *); + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real lstres; + extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex + *, integer *, integer *, complex *, integer *, integer *); + real eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldx < f2cmax(1,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.f; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, & + c_b1, &work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[i__] = (r__1 = b[i__3].r, abs(r__1)) + (r__2 = r_imag(&b[ + i__ + j * b_dim1]), abs(r__2)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + k * a_dim1; + rwork[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * xk; + i__4 = i__ + k * a_dim1; + i__5 = i__ + j * x_dim1; + s += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + k * a_dim1]), abs(r__2))) * ((r__3 = x[i__5] + .r, abs(r__3)) + (r__4 = r_imag(&x[i__ + j * + x_dim1]), abs(r__4))); +/* L40: */ + } + i__3 = k + k * a_dim1; + rwork[k] = rwork[k] + ((r__1 = a[i__3].r, abs(r__1)) + (r__2 = + r_imag(&a[k + k * a_dim1]), abs(r__2))) * xk + s; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k + j * x_dim1; + xk = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[k + j * + x_dim1]), abs(r__2)); + i__3 = k + k * a_dim1; + rwork[k] += ((r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag(& + a[k + k * a_dim1]), abs(r__2))) * xk; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = i__ + k * a_dim1; + rwork[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * xk; + i__4 = i__ + k * a_dim1; + i__5 = i__ + j * x_dim1; + s += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag(&a[ + i__ + k * a_dim1]), abs(r__2))) * ((r__3 = x[i__5] + .r, abs(r__3)) + (r__4 = r_imag(&x[i__ + j * + x_dim1]), abs(r__4))); +/* L60: */ + } + rwork[k] += s; +/* L70: */ + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2))) / rwork[i__]; + s = f2cmax(r__3,r__4); + } else { +/* Computing MAX */ + i__3 = i__; + r__3 = s, r__4 = ((r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(r__3,r__4); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { + +/* Update solution and try again. */ + + csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1], + n, info); + caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + ; + } else { + i__3 = i__; + rwork[i__] = (r__1 = work[i__3].r, abs(r__1)) + (r__2 = + r_imag(&work[i__]), abs(r__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**T). */ + + csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L120: */ + } + csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * x_dim1; + r__3 = lstres, r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = + r_imag(&x[i__ + j * x_dim1]), abs(r__2)); + lstres = f2cmax(r__3,r__4); +/* L130: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of CSYRFS */ + +} /* csyrfs_ */ + diff --git a/lapack-netlib/SRC/csyrfsx.c b/lapack-netlib/SRC/csyrfsx.c new file mode 100644 index 000000000..e8dddda2b --- /dev/null +++ b/lapack-netlib/SRC/csyrfsx.c @@ -0,0 +1,381 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYSV computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, LWORK, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > The diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */ +/* > used to solve the system of equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the block diagonal matrix D and the */ +/* > multipliers used to obtain the factor U or L from the */ +/* > factorization A = U*D*U**T or A = L*D*L**T as computed by */ +/* > CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, as */ +/* > determined by CSYTRF. If IPIV(k) > 0, then rows and columns */ +/* > k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */ +/* > diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */ +/* > then rows and columns k-1 and -IPIV(k) were interchanged and */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */ +/* > IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */ +/* > -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */ +/* > diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= 1, and for best performance */ +/* > LWORK >= f2cmax(1,N*NB), where NB is the optimal blocksize for */ +/* > CSYTRF. */ +/* > for LWORK < N, TRS will be done with Level BLAS 2 */ +/* > for LWORK >= N, TRS will be done with Level BLAS 3 */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, so the solution could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int csysv_(char *uplo, integer *n, integer *nrhs, complex *a, + integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), csytrf_( + char *, integer *, complex *, integer *, integer *, complex *, + integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex + *, integer *, integer *, complex *, integer *, integer *), + csytrs2_(char *, integer *, integer *, complex *, integer *, + integer *, complex *, integer *, complex *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*lwork < 1 && ! lquery) { + *info = -10; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + csytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &c_n1, + info); + lwkopt = work[1].r; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYSV ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + csytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + if (*lwork < *n) { + +/* Solve with TRS ( Use Level BLAS 2) */ + + csytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, info); + + } else { + +/* Solve with TRS2 ( Use Level BLAS 3) */ + + csytrs2_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, &work[1], info); + + } + + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CSYSV */ + +} /* csysv_ */ + diff --git a/lapack-netlib/SRC/csysv_aa.c b/lapack-netlib/SRC/csysv_aa.c new file mode 100644 index 000000000..f9040f9e7 --- /dev/null +++ b/lapack-netlib/SRC/csysv_aa.c @@ -0,0 +1,651 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSV_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LDB, LWORK, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > Aasen's algorithm is used to factor A as */ +/* > A = U**T * T * U, if UPLO = 'U', or */ +/* > A = L * T * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is symmetric tridiagonal. The factored */ +/* > form of A is then used to solve the system of equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the tridiagonal matrix T and the */ +/* > multipliers used to obtain the factor U or L from the */ +/* > factorization A = U**T*T*U or A = L*T*L**T as computed by */ +/* > CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > On exit, it contains the details of the interchanges, i.e., */ +/* > the row and column k of A were interchanged with the */ +/* > row and column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= MAX(2*N, 3*N-2), and for */ +/* > the best performance, LWORK >= f2cmax(1,N*NB), where NB is */ +/* > the optimal blocksize for CSYTRF_AA. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, so the solution could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int csysv_aa_(char *uplo, integer *n, integer *nrhs, + complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, + complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + integer lwkopt_sytrf__, lwkopt_sytrs__; + extern /* Subroutine */ int csytrf_aa_(char *, integer *, complex *, + integer *, integer *, complex *, integer *, integer *), + csytrs_aa_(char *, integer *, integer *, complex *, integer *, + integer *, complex *, integer *, complex *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = *n << 1, i__2 = *n * 3 - 2; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -10; + } + } + + if (*info == 0) { + csytrf_aa_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &c_n1, + info); + lwkopt_sytrf__ = (integer) work[1].r; + csytrs_aa_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, &work[1], &c_n1, info); + lwkopt_sytrs__ = (integer) work[1].r; + lwkopt = f2cmax(lwkopt_sytrf__,lwkopt_sytrs__); + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYSV_AA ", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U**T*T*U or A = L*T*L**T. */ + + csytrf_aa_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + csytrs_aa_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], + ldb, &work[1], lwork, info); + + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CSYSV_AA */ + +} /* csysv_aa__ */ + diff --git a/lapack-netlib/SRC/csysv_aa_2stage.c b/lapack-netlib/SRC/csysv_aa_2stage.c new file mode 100644 index 000000000..3d3be6174 --- /dev/null +++ b/lapack-netlib/SRC/csysv_aa_2stage.c @@ -0,0 +1,678 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices + */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSV_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSV_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, */ +/* IPIV, IPIV2, B, LDB, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LTB, LDB, LWORK, INFO */ +/* INTEGER IPIV( * ), IPIV2( * ) */ +/* COMPLEX A( LDA, * ), TB( * ), B( LDB, *), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYSV_AA_2STAGE computes the solution to a complex system of */ +/* > linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > Aasen's 2-stage algorithm is used to factor A as */ +/* > A = U**T * T * U, if UPLO = 'U', or */ +/* > A = L * T * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is symmetric and band. The matrix T is */ +/* > then LU-factored with partial pivoting. The factored form of A */ +/* > is then used to solve the system of equations A * X = B. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, L is stored below (or above) the subdiaonal blocks, */ +/* > when UPLO is 'L' (or 'U'). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TB */ +/* > \verbatim */ +/* > TB is COMPLEX array, dimension (LTB) */ +/* > On exit, details of the LU factorization of the band matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LTB */ +/* > \verbatim */ +/* > LTB is INTEGER */ +/* > The size of the array TB. LTB >= 4*N, internally */ +/* > used to select NB such that LTB >= (3*NB+1)*N. */ +/* > */ +/* > If LTB = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of LTB, */ +/* > returns this value as the first entry of TB, and */ +/* > no error message related to LTB is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > On exit, it contains the details of the interchanges, i.e., */ +/* > the row and column k of A were interchanged with the */ +/* > row and column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV2 */ +/* > \verbatim */ +/* > IPIV2 is INTEGER array, dimension (N) */ +/* > On exit, it contains the details of the interchanges, i.e., */ +/* > the row and column k of T were interchanged with the */ +/* > row and column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX workspace of size LWORK */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The size of WORK. LWORK >= N, internally used to select NB */ +/* > such that LWORK >= N*NB. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the WORK array, */ +/* > returns this value as the first entry of the WORK array, and */ +/* > no error message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, band LU factorization failed on i-th column */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csysv_aa_2stage_(char *uplo, integer *n, integer *nrhs, + complex *a, integer *lda, complex *tb, integer *ltb, integer *ipiv, + integer *ipiv2, complex *b, integer *ldb, complex *work, integer * + lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int csytrf_aa_2stage_(char *, integer *, complex + *, integer *, complex *, integer *, integer *, integer *, complex + *, integer *, integer *), csytrs_aa_2stage_(char *, + integer *, integer *, complex *, integer *, complex *, integer *, + integer *, integer *, complex *, integer *, integer *); + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical tquery, wquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tb; + --ipiv; + --ipiv2; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + wquery = *lwork == -1; + tquery = *ltb == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ltb < *n << 2 && ! tquery) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -11; + } else if (*lwork < *n && ! wquery) { + *info = -13; + } + + if (*info == 0) { + csytrf_aa_2stage_(uplo, n, &a[a_offset], lda, &tb[1], &c_n1, &ipiv[1] + , &ipiv2[1], &work[1], &c_n1, info); + lwkopt = (integer) work[1].r; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYSV_AA_2STAGE", &i__1, (ftnlen)15); + return 0; + } else if (wquery || tquery) { + return 0; + } + + +/* Compute the factorization A = U**T*T*U or A = L*T*L**T. */ + + csytrf_aa_2stage_(uplo, n, &a[a_offset], lda, &tb[1], ltb, &ipiv[1], & + ipiv2[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + csytrs_aa_2stage_(uplo, n, nrhs, &a[a_offset], lda, &tb[1], ltb, & + ipiv[1], &ipiv2[1], &b[b_offset], ldb, info); + + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CSYSV_AA_2STAGE */ + +} /* csysv_aa_2stage__ */ + diff --git a/lapack-netlib/SRC/csysv_rk.c b/lapack-netlib/SRC/csysv_rk.c new file mode 100644 index 000000000..57c812b62 --- /dev/null +++ b/lapack-netlib/SRC/csysv_rk.c @@ -0,0 +1,716 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSV_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, LWORK, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CSYSV_RK computes the solution to a complex system of linear */ +/* > equations A * X = B, where A is an N-by-N symmetric matrix */ +/* > and X and B are N-by-NRHS matrices. */ +/* > */ +/* > The bounded Bunch-Kaufman (rook) diagonal pivoting method is used */ +/* > to factor A as */ +/* > A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or */ +/* > A = P*L*D*(L**T)*(P**T), if UPLO = 'L', */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > CSYTRF_RK is called to compute the factorization of a complex */ +/* > symmetric matrix. The factored form of A is then used to solve */ +/* > the system of equations A * X = B by calling BLAS3 routine CSYTRS_3. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. */ +/* > If UPLO = 'U': the leading N-by-N upper triangular part */ +/* > of A contains the upper triangular part of the matrix A, */ +/* > and the strictly lower triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > If UPLO = 'L': the leading N-by-N lower triangular part */ +/* > of A contains the lower triangular part of the matrix A, */ +/* > and the strictly upper triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > On exit, if INFO = 0, diagonal of the block diagonal */ +/* > matrix D and factors U or L as computed by CSYTRF_RK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > For more info see the description of CSYTRF_RK routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N) */ +/* > On exit, contains the output computed by the factorization */ +/* > routine CSYTRF_RK, i.e. the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > */ +/* > For more info see the description of CSYTRF_RK routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, */ +/* > as determined by CSYTRF_RK. */ +/* > */ +/* > For more info see the description of CSYTRF_RK routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension ( MAX(1,LWORK) ). */ +/* > Work array used in the factorization stage. */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= 1. For best performance */ +/* > of factorization stage LWORK >= f2cmax(1,N*NB), where NB is */ +/* > the optimal blocksize for CSYTRF_RK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; */ +/* > the routine only calculates the optimal size of the WORK */ +/* > array for factorization stage, returns this value as */ +/* > the first entry of the WORK array, and no error message */ +/* > related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > < 0: If INFO = -k, the k-th argument had an illegal value */ +/* > */ +/* > > 0: If INFO = k, the matrix A is singular, because: */ +/* > If UPLO = 'U': column k in the upper */ +/* > triangular part of A contains all zeros. */ +/* > If UPLO = 'L': column k in the lower */ +/* > triangular part of A contains all zeros. */ +/* > */ +/* > Therefore D(k,k) is exactly zero, and superdiagonal */ +/* > elements of column k of U (or subdiagonal elements of */ +/* > column k of L ) are all zeros. The factorization has */ +/* > been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if */ +/* > it is used to solve a system of equations. */ +/* > */ +/* > NOTE: INFO only stores the first occurrence of */ +/* > a singularity, any subsequent occurrence of singularity */ +/* > is not stored in INFO even though the factorization */ +/* > always completes. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYsolve */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > December 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csysv_rk_(char *uplo, integer *n, integer *nrhs, + complex *a, integer *lda, complex *e, integer *ipiv, complex *b, + integer *ldb, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int csytrs_3_(char *, integer *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int csytrf_rk_(char *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*lwork < 1 && ! lquery) { + *info = -11; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + csytrf_rk_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], + &c_n1, info); + lwkopt = work[1].r; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYSV_RK ", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + csytrf_rk_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], lwork, + info); + + if (*info == 0) { + +/* Solve the system A*X = B with BLAS3 solver, overwriting B with X. */ + + csytrs_3_(uplo, n, nrhs, &a[a_offset], lda, &e[1], &ipiv[1], &b[ + b_offset], ldb, info); + + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CSYSV_RK */ + +} /* csysv_rk__ */ + diff --git a/lapack-netlib/SRC/csysv_rook.c b/lapack-netlib/SRC/csysv_rook.c new file mode 100644 index 000000000..114ebe32a --- /dev/null +++ b/lapack-netlib/SRC/csysv_rook.c @@ -0,0 +1,692 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSV_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, LWORK, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYSV_ROOK computes the solution to a complex system of linear */ +/* > equations */ +/* > A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > The diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > CSYTRF_ROOK is called to compute the factorization of a complex */ +/* > symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal */ +/* > pivoting method. */ +/* > */ +/* > The factored form of A is then used to solve the system */ +/* > of equations A * X = B by calling CSYTRS_ROOK. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if INFO = 0, the block diagonal matrix D and the */ +/* > multipliers used to obtain the factor U or L from the */ +/* > factorization A = U*D*U**T or A = L*D*L**T as computed by */ +/* > CSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, */ +/* > as determined by CSYTRF_ROOK. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= 1, and for best performance */ +/* > LWORK >= f2cmax(1,N*NB), where NB is the optimal blocksize for */ +/* > CSYTRF_ROOK. */ +/* > */ +/* > TRS will be done with Level 2 BLAS */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, so the solution could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexSYsolve */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > April 2012, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csysv_rook_(char *uplo, integer *n, integer *nrhs, + complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, + complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int csytrf_rook_(char *, integer *, complex *, + integer *, integer *, complex *, integer *, integer *), + csytrs_rook_(char *, integer *, integer *, complex *, integer *, + integer *, complex *, integer *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*lwork < 1 && ! lquery) { + *info = -10; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + csytrf_rook_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], & + c_n1, info); + lwkopt = work[1].r; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYSV_ROOK ", &i__1, (ftnlen)11); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + csytrf_rook_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + +/* Solve with TRS_ROOK ( Use Level 2 BLAS) */ + + csytrs_rook_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset] + , ldb, info); + + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CSYSV_ROOK */ + +} /* csysv_rook__ */ + diff --git a/lapack-netlib/SRC/csysvx.c b/lapack-netlib/SRC/csysvx.c new file mode 100644 index 000000000..6c05e3c9b --- /dev/null +++ b/lapack-netlib/SRC/csysvx.c @@ -0,0 +1,844 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYSVX computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, */ +/* LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, */ +/* RWORK, INFO ) */ + +/* CHARACTER FACT, UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS */ +/* REAL RCOND */ +/* INTEGER IPIV( * ) */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYSVX uses the diagonal pivoting factorization to compute the */ +/* > solution to a complex system of linear equations A * X = B, */ +/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */ +/* > The form of the factorization is */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > 2. If some D(i,i)=0, so that D is exactly singular, then the routine */ +/* > returns with INFO = i. Otherwise, the factored form of A is used */ +/* > to estimate the condition number of the matrix A. If the */ +/* > reciprocal of the condition number is less than machine precision, */ +/* > INFO = N+1 is returned as a warning, but the routine still goes on */ +/* > to solve for X and compute error bounds as described below. */ +/* > */ +/* > 3. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 4. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of A has been */ +/* > supplied on entry. */ +/* > = 'F': On entry, AF and IPIV contain the factored form */ +/* > of A. A, AF and IPIV will not be modified. */ +/* > = 'N': The matrix A will be copied to AF and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular part */ +/* > of the matrix A, and the strictly lower triangular part of A */ +/* > is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of A contains the lower triangular part of */ +/* > the matrix A, and the strictly upper triangular part of A is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AF */ +/* > \verbatim */ +/* > AF is COMPLEX array, dimension (LDAF,N) */ +/* > If FACT = 'F', then AF is an input argument and on entry */ +/* > contains the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**T or A = L*D*L**T as computed by CSYTRF. */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**T or A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains details of the interchanges and the block structure */ +/* > of D, as determined by CSYTRF. */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* > columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* > IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* > interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains details of the interchanges and the block structure */ +/* > of D, as determined by CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > The N-by-NRHS right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX 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 REAL */ +/* > 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 REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= f2cmax(1,2*N), and for best */ +/* > performance, when FACT = 'N', LWORK >= f2cmax(1,2*N,N*NB), where */ +/* > NB is the optimal blocksize for CSYTRF. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: D(i,i) is exactly zero. The factorization */ +/* > has been completed but the factor D is exactly */ +/* > singular, so the solution and error bounds could */ +/* > not be computed. RCOND = 0 is returned. */ +/* > = N+1: D is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int csysvx_(char *fact, char *uplo, integer *n, integer * + nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer * + ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, + real *ferr, real *berr, complex *work, integer *lwork, real *rwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + real anorm; + integer nb; + extern real slamch_(char *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern real clansy_(char *, char *, integer *, complex *, integer *, real + *); + extern /* Subroutine */ int csycon_(char *, integer *, complex *, integer + *, integer *, real *, real *, complex *, integer *), + csyrfs_(char *, integer *, integer *, complex *, integer *, + complex *, integer *, integer *, complex *, integer *, complex *, + integer *, real *, real *, complex *, real *, integer *), + csytrf_(char *, integer *, complex *, integer *, integer *, + complex *, integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex + *, integer *, integer *, complex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + lquery = *lwork == -1; + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -11; + } else if (*ldx < f2cmax(1,*n)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 1; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -18; + } + } + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 1; + lwkopt = f2cmax(i__1,i__2); + if (nofact) { + nb = ilaenv_(&c__1, "CSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * nb; + lwkopt = f2cmax(i__1,i__2); + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYSVX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + + if (nofact) { + +/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */ + + clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + csytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork, + info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.f; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = clansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]); + +/* Compute the reciprocal of the condition number of A. */ + + csycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], + info); + +/* Compute the solution vectors X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, + info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + csyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], + &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] + , &rwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < slamch_("Epsilon")) { + *info = *n + 1; + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CSYSVX */ + +} /* csysvx_ */ + diff --git a/lapack-netlib/SRC/csysvxx.c b/lapack-netlib/SRC/csysvxx.c new file mode 100644 index 000000000..4c6ef5a70 --- /dev/null +++ b/lapack-netlib/SRC/csysvxx.c @@ -0,0 +1,1125 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CSYSVXX computes the solution to system of linear equations A * X = B for SY matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSVXX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, */ +/* EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, */ +/* N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, */ +/* NPARAMS, PARAMS, WORK, RWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, UPLO */ +/* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, */ +/* $ N_ERR_BNDS */ +/* REAL RCOND, RPVGRW */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ X( LDX, * ), WORK( * ) */ +/* REAL S( * ), PARAMS( * ), BERR( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYSVXX uses the diagonal pivoting factorization to compute the */ +/* > solution to a complex system of linear equations A * X = B, where */ +/* > A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* > matrices. */ +/* > */ +/* > If requested, both normwise and maximum componentwise error bounds */ +/* > are returned. CSYSVXX will return a solution with a tiny */ +/* > guaranteed error (O(eps) where eps is the working machine */ +/* > precision) unless the matrix is very ill-conditioned, in which */ +/* > case a warning is returned. Relevant condition numbers also are */ +/* > calculated and returned. */ +/* > */ +/* > CSYSVXX accepts user-provided factorizations and equilibration */ +/* > factors; see the definitions of the FACT and EQUED options. */ +/* > Solving with refinement and using a factorization from a previous */ +/* > CSYSVXX call will also produce a solution with either O(eps) */ +/* > errors or warnings, but we cannot make that claim for general */ +/* > user-provided factorizations and equilibration factors if they */ +/* > differ from what CSYSVXX would itself produce. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > */ +/* > diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */ +/* > */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ +/* > the matrix A (after equilibration if FACT = 'E') as */ +/* > */ +/* > A = U * D * U**T, if UPLO = 'U', or */ +/* > A = L * D * L**T, if UPLO = 'L', */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > 3. If some D(i,i)=0, so that D is exactly singular, then the */ +/* > routine returns with INFO = i. Otherwise, the factored form of A */ +/* > is used to estimate the condition number of the matrix A (see */ +/* > argument RCOND). If the reciprocal of the condition number is */ +/* > less than machine precision, the routine still goes on to solve */ +/* > for X and compute error bounds as described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ +/* > the routine will use iterative refinement to try to get a small */ +/* > error and error bounds. Refinement calculates the residual to at */ +/* > least twice the working precision. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(R) so that it solves the original system before */ +/* > equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > Some optional parameters are bundled in the PARAMS array. These */ +/* > settings determine how refinement is performed, but often the */ +/* > defaults are acceptable. If the defaults are acceptable, users */ +/* > can pass NPARAMS = 0 which prevents the source code from accessing */ +/* > the PARAMS argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AF and IPIV contain the factored form of A. */ +/* > If EQUED is not 'N', the matrix A has been */ +/* > equilibrated with scaling factors given by S. */ +/* > A, AF, and IPIV are not modified. */ +/* > = 'N': The matrix A will be copied to AF and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AF and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of A contains the upper triangular */ +/* > part of the matrix A, and the strictly lower triangular */ +/* > part of A is not referenced. If UPLO = 'L', the leading */ +/* > N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* > diag(S)*A*diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AF */ +/* > \verbatim */ +/* > AF is COMPLEX array, dimension (LDAF,N) */ +/* > If FACT = 'F', then AF is an input argument and on entry */ +/* > contains the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L from the factorization A = */ +/* > U*D*U**T or A = L*D*L**T as computed by SSYTRF. */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L from the factorization A = */ +/* > U*D*U**T or A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains details of the interchanges and the block */ +/* > structure of D, as determined by SSYTRF. If IPIV(k) > 0, */ +/* > then rows and columns k and IPIV(k) were interchanged and */ +/* > D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */ +/* > IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */ +/* > -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */ +/* > diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */ +/* > then rows and columns k+1 and -IPIV(k) were interchanged */ +/* > and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains details of the interchanges and the block */ +/* > structure of D, as determined by SSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'Y': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(S) * A * diag(S). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The scale factors for A. If EQUED = 'Y', A is multiplied on */ +/* > the left and right by diag(S). S is an input argument if FACT = */ +/* > 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ +/* > = 'Y', each element of S must be positive. If S is output, each */ +/* > element of S is a power of the radix. If S is input, each element */ +/* > of S should be a power of the radix to ensure a reliable solution */ +/* > and error estimates. Scaling by powers of the radix does not cause */ +/* > rounding errors unless the result underflows or overflows. */ +/* > Rounding errors during scaling lead to refining with a matrix that */ +/* > is not equivalent to the input matrix, producing error estimates */ +/* > that may not be reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, */ +/* > if EQUED = 'N', B is not modified; */ +/* > if EQUED = 'Y', B is overwritten by diag(S)*B; */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X to the original */ +/* > system of equations. Note that A and B are modified on exit if */ +/* > EQUED .ne. 'N', and the solution to the equilibrated system is */ +/* > inv(diag(S))*X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RPVGRW */ +/* > \verbatim */ +/* > RPVGRW is REAL */ +/* > Reciprocal pivot growth. On exit, this contains the reciprocal */ +/* > pivot growth factor norm(A)/norm(U). The "f2cmax absolute element" */ +/* > norm is used. If this is much less than 1, then the stability of */ +/* > the LU factorization of the (equilibrated) matrix A could be poor. */ +/* > This also means that the solution X, estimated condition numbers, */ +/* > and error bounds could be unreliable. If factorization fails with */ +/* > 0 for the leading INFO columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > Componentwise relative backward error. This is the */ +/* > componentwise relative backward error of each solution vector X(j) */ +/* > (i.e., the smallest relative change in any element of A or B that */ +/* > makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_ERR_BNDS */ +/* > \verbatim */ +/* > N_ERR_BNDS is INTEGER */ +/* > Number of error bounds to return for each right hand side */ +/* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* > ERR_BNDS_COMP below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NPARAMS */ +/* > \verbatim */ +/* > NPARAMS is INTEGER */ +/* > Specifies the number of parameters set in PARAMS. If <= 0, the */ +/* > PARAMS array is never referenced and default values are used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PARAMS */ +/* > \verbatim */ +/* > PARAMS is REAL array, dimension NPARAMS */ +/* > Specifies algorithm parameters. If an entry is < 0.0, then */ +/* > that entry will be filled with default value used for that */ +/* > parameter. Only positions up to NPARAMS are accessed; defaults */ +/* > are used for higher-numbered parameters. */ +/* > */ +/* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* > refinement or not. */ +/* > Default: 1.0 */ +/* > = 0.0: No refinement is performed, and no error bounds are */ +/* > computed. */ +/* > = 1.0: Use the double-precision refinement algorithm, */ +/* > possibly with doubled-single computations if the */ +/* > compilation environment does not support DOUBLE */ +/* > PRECISION. */ +/* > (other values are reserved for future use) */ +/* > */ +/* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* > computations allowed for refinement. */ +/* > Default: 10 */ +/* > Aggressive: Set to 100 to permit convergence using approximate */ +/* > factorizations or factorizations other than LU. If */ +/* > the factorization uses a technique other than */ +/* > Gaussian elimination, the guarantees in */ +/* > err_bnds_norm and err_bnds_comp may no longer be */ +/* > trustworthy. */ +/* > */ +/* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* > will attempt to find a solution with small componentwise */ +/* > relative error in the double-precision algorithm. Positive */ +/* > is true, 0.0 is false. */ +/* > Default: 1.0 (attempt componentwise convergence) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. The solution to every right-hand side is */ +/* > guaranteed. */ +/* > < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly singular, so */ +/* > the solution and error bounds could not be computed. RCOND = 0 */ +/* > is returned. */ +/* > = N+J: The solution corresponding to the Jth right-hand side is */ +/* > not guaranteed. The solutions corresponding to other right- */ +/* > hand sides K with K > J may not be guaranteed as well, but */ +/* > only the first such right-hand side is reported. If a small */ +/* > componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* > the Jth right-hand side is the first with a normwise error */ +/* > bound that is not guaranteed (the smallest J such */ +/* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* > the Jth right-hand side is the first with either a normwise or */ +/* > componentwise error bound that is not guaranteed (the smallest */ +/* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* > about all of the right-hand sides check ERR_BNDS_NORM or */ +/* > ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexSYsolve */ + +/* ===================================================================== */ +/* Subroutine */ int csysvxx_(char *fact, char *uplo, integer *n, integer * + nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer * + ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x, + integer *ldx, real *rcond, real *rpvgrw, real *berr, integer * + n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer * + nparams, real *params, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + real r__1, r__2; + + /* Local variables */ + real amax, smin, smax; + integer j; + extern real cla_syrpvgrw_(char *, integer *, integer *, complex *, + integer *, complex *, integer *, integer *, real *); + extern logical lsame_(char *, char *); + real scond; + logical equil, rcequ; + extern real slamch_(char *); + logical nofact; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real bignum; + integer infequ; + extern /* Subroutine */ int claqsy_(char *, integer *, complex *, integer + *, real *, real *, real *, char *), csytrf_(char * + , integer *, complex *, integer *, integer *, complex *, integer * + , integer *); + real smlnum; + extern /* Subroutine */ int clascl2_(integer *, integer *, real *, + complex *, integer *), csytrs_(char *, integer *, integer *, + complex *, integer *, integer *, complex *, integer *, integer *), csyequb_(char *, integer *, complex *, integer *, real *, + real *, real *, complex *, integer *), csyrfsx_(char *, + char *, integer *, integer *, complex *, integer *, complex *, + integer *, integer *, real *, complex *, integer *, complex *, + integer *, real *, real *, integer *, real *, real *, integer *, + real *, complex *, real *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ================================================================== */ + + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --berr; + --params; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = FALSE_; + } else { + rcequ = lsame_(equed, "Y"); + } + +/* Default is failure. If an input parameter is wrong or */ +/* factorization fails, make everything look horrible. Only the */ +/* pivot growth is set here, the rest is initialized in CSYRFSX. */ + + *rpvgrw = 0.f; + +/* Test the input parameters. PARAMS is not tested until CSYRFSX. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -10; + } else { + if (rcequ) { + smin = bignum; + smax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = smin, r__2 = s[j]; + smin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = smax, r__2 = s[j]; + smax = f2cmax(r__1,r__2); +/* L10: */ + } + if (smin <= 0.f) { + *info = -11; + } else if (*n > 0) { + scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum); + } else { + scond = 1.f; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldx < f2cmax(1,*n)) { + *info = -15; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYSVXX", &i__1, (ftnlen)7); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + csyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], & + infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + claqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right hand-side. */ + + if (rcequ) { + clascl2_(n, nrhs, &s[1], &b[b_offset], ldb); + } + + if (nofact || equil) { + +/* Compute the LDL^T or UDU^T factorization of A. */ + + clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + i__1 = f2cmax(1,*n) * 5; + csytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1, + info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Pivot in column INFO is exactly 0 */ +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + if (*n > 0) { + *rpvgrw = cla_syrpvgrw_(uplo, n, info, &a[a_offset], lda, & + af[af_offset], ldaf, &ipiv[1], &rwork[1]); + } + return 0; + } + } + +/* Compute the reciprocal pivot growth factor RPVGRW. */ + + if (*n > 0) { + *rpvgrw = cla_syrpvgrw_(uplo, n, info, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &rwork[1]); + } + +/* Compute the solution matrix X. */ + + clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, + info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + csyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, & + ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, & + berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], & + err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[ + 1], &rwork[1], info); + +/* Scale solutions. */ + + if (rcequ) { + clascl2_(n, nrhs, &s[1], &x[x_offset], ldx); + } + + return 0; + +/* End of CSYSVXX */ + +} /* csysvxx_ */ + diff --git a/lapack-netlib/SRC/csyswapr.c b/lapack-netlib/SRC/csyswapr.c new file mode 100644 index 000000000..0e4cb8b43 --- /dev/null +++ b/lapack-netlib/SRC/csyswapr.c @@ -0,0 +1,617 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYSWAPR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYSWAPR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYSWAPR( UPLO, N, A, LDA, I1, I2) */ + +/* CHARACTER UPLO */ +/* INTEGER I1, I2, LDA, N */ +/* COMPLEX A( LDA, N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYSWAPR applies an elementary permutation on the rows and the columns of */ +/* > a symmetric matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the NB diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by CSYTRF. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix. If UPLO = 'U', the upper triangular part of the */ +/* > inverse is formed and the part of A below the diagonal is not */ +/* > referenced; if UPLO = 'L' the lower triangular part of the */ +/* > inverse is formed and the part of A above the diagonal is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I1 */ +/* > \verbatim */ +/* > I1 is INTEGER */ +/* > Index of the first row to swap */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I2 */ +/* > \verbatim */ +/* > I2 is INTEGER */ +/* > Index of the second row to swap */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int csyswapr_(char *uplo, integer *n, complex *a, integer * + lda, integer *i1, integer *i2) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + logical upper; + complex tmp; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + upper = lsame_(uplo, "U"); + if (upper) { + +/* UPPER */ +/* first swap */ +/* - swap column I1 and I2 from I1 to I1-1 */ + i__1 = *i1 - 1; + cswap_(&i__1, &a[*i1 * a_dim1 + 1], &c__1, &a[*i2 * a_dim1 + 1], & + c__1); + +/* second swap : */ +/* - swap A(I1,I1) and A(I2,I2) */ +/* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 */ + i__1 = *i1 + *i1 * a_dim1; + tmp.r = a[i__1].r, tmp.i = a[i__1].i; + i__1 = *i1 + *i1 * a_dim1; + i__2 = *i2 + *i2 * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = *i2 + *i2 * a_dim1; + a[i__1].r = tmp.r, a[i__1].i = tmp.i; + + i__1 = *i2 - *i1 - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *i1 + (*i1 + i__) * a_dim1; + tmp.r = a[i__2].r, tmp.i = a[i__2].i; + i__2 = *i1 + (*i1 + i__) * a_dim1; + i__3 = *i1 + i__ + *i2 * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = *i1 + i__ + *i2 * a_dim1; + a[i__2].r = tmp.r, a[i__2].i = tmp.i; + } + +/* third swap */ +/* - swap row I1 and I2 from I2+1 to N */ + i__1 = *n; + for (i__ = *i2 + 1; i__ <= i__1; ++i__) { + i__2 = *i1 + i__ * a_dim1; + tmp.r = a[i__2].r, tmp.i = a[i__2].i; + i__2 = *i1 + i__ * a_dim1; + i__3 = *i2 + i__ * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = *i2 + i__ * a_dim1; + a[i__2].r = tmp.r, a[i__2].i = tmp.i; + } + + } else { + +/* LOWER */ +/* first swap */ +/* - swap row I1 and I2 from I1 to I1-1 */ + i__1 = *i1 - 1; + cswap_(&i__1, &a[*i1 + a_dim1], lda, &a[*i2 + a_dim1], lda); + +/* second swap : */ +/* - swap A(I1,I1) and A(I2,I2) */ +/* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 */ + i__1 = *i1 + *i1 * a_dim1; + tmp.r = a[i__1].r, tmp.i = a[i__1].i; + i__1 = *i1 + *i1 * a_dim1; + i__2 = *i2 + *i2 * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = *i2 + *i2 * a_dim1; + a[i__1].r = tmp.r, a[i__1].i = tmp.i; + + i__1 = *i2 - *i1 - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *i1 + i__ + *i1 * a_dim1; + tmp.r = a[i__2].r, tmp.i = a[i__2].i; + i__2 = *i1 + i__ + *i1 * a_dim1; + i__3 = *i2 + (*i1 + i__) * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = *i2 + (*i1 + i__) * a_dim1; + a[i__2].r = tmp.r, a[i__2].i = tmp.i; + } + +/* third swap */ +/* - swap col I1 and I2 from I2+1 to N */ + i__1 = *n; + for (i__ = *i2 + 1; i__ <= i__1; ++i__) { + i__2 = i__ + *i1 * a_dim1; + tmp.r = a[i__2].r, tmp.i = a[i__2].i; + i__2 = i__ + *i1 * a_dim1; + i__3 = i__ + *i2 * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + i__2 = i__ + *i2 * a_dim1; + a[i__2].r = tmp.r, a[i__2].i = tmp.i; + } + + } + return 0; +} /* csyswapr_ */ + diff --git a/lapack-netlib/SRC/csytf2_rk.c b/lapack-netlib/SRC/csytf2_rk.c new file mode 100644 index 000000000..4a39a29f0 --- /dev/null +++ b/lapack-netlib/SRC/csytf2_rk.c @@ -0,0 +1,1565 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded + Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTF2_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E ( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CSYTF2_RK computes the factorization of a complex symmetric matrix A */ +/* > using the bounded Bunch-Kaufman (rook) diagonal pivoting method: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > For more information see Further Details section. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. */ +/* > If UPLO = 'U': the leading N-by-N upper triangular part */ +/* > of A contains the upper triangular part of the matrix A, */ +/* > and the strictly lower triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > If UPLO = 'L': the leading N-by-N lower triangular part */ +/* > of A contains the lower triangular part of the matrix A, */ +/* > and the strictly upper triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > On exit, contains: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (N) */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > IPIV describes the permutation matrix P in the factorization */ +/* > of matrix A as follows. The absolute value of IPIV(k) */ +/* > represents the index of row and column that were */ +/* > interchanged with the k-th row and column. The value of UPLO */ +/* > describes the order in which the interchanges were applied. */ +/* > Also, the sign of IPIV represents the block structure of */ +/* > the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 */ +/* > diagonal blocks which correspond to 1 or 2 interchanges */ +/* > at each factorization step. For more info see Further */ +/* > Details section. */ +/* > */ +/* > If UPLO = 'U', */ +/* > ( in factorization order, k decreases from N to 1 ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the matrix A(1:N,1:N); */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k-1) < 0 means: */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k-1) != k-1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k-1) = k-1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b), always ABS( IPIV(k) ) <= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > */ +/* > If UPLO = 'L', */ +/* > ( in factorization order, k increases from 1 to N ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the matrix A(1:N,1:N). */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k+1) < 0 means: */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k+1) != k+1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k+1) = k+1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b), always ABS( IPIV(k) ) >= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > < 0: If INFO = -k, the k-th argument had an illegal value */ +/* > */ +/* > > 0: If INFO = k, the matrix A is singular, because: */ +/* > If UPLO = 'U': column k in the upper */ +/* > triangular part of A contains all zeros. */ +/* > If UPLO = 'L': column k in the lower */ +/* > triangular part of A contains all zeros. */ +/* > */ +/* > Therefore D(k,k) is exactly zero, and superdiagonal */ +/* > elements of column k of U (or subdiagonal elements of */ +/* > column k of L ) are all zeros. The factorization has */ +/* > been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if */ +/* > it is used to solve a system of equations. */ +/* > */ +/* > NOTE: INFO only stores the first occurrence of */ +/* > a singularity, any subsequent occurrence of singularity */ +/* > is not stored in INFO even though the factorization */ +/* > always completes. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > TODO: put further details */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > December 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > 01-01-96 - Based on modifications by */ +/* > J. Lewis, Boeing Computer Services Company */ +/* > A. Petitet, Computer Science Dept., */ +/* > Univ. of Tenn., Knoxville abd , USA */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csytf2_rk_(char *uplo, integer *n, complex *a, integer * + lda, complex *e, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + real r__1, r__2; + complex q__1, q__2, q__3, q__4, q__5, q__6; + + /* Local variables */ + logical done; + integer imax, jmax; + extern /* Subroutine */ int csyr_(char *, integer *, complex *, complex *, + integer *, complex *, integer *); + integer i__, j, k, p; + complex t; + real alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + real sfmin; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + integer itemp, kstep; + real stemp; + logical upper; + complex d11, d12, d21, d22; + integer ii, kk, kp; + real absakk; + complex wk; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real colmax, rowmax; + complex wkm1, wkp1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTF2_RK", &i__1, (ftnlen)9); + return 0; + } + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + +/* Compute machine safe minimum */ + + sfmin = slamch_("S"); + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* Initialize the first entry of array E, where superdiagonal */ +/* elements of D are stored */ + + e[1].r = 0.f, e[1].i = 0.f; + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2 */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L34; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * a_dim1; + absakk = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + k * + a_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &a[k * a_dim1 + 1], &c__1); + i__1 = imax + k * a_dim1; + colmax = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[imax + + k * a_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + +/* Set E( K ) to zero */ + + if (k > 1) { + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + + } else { + +/* Test for interchange */ + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABSAKK.GE.ALPHA*COLMAX */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, */ +/* use 1-by-1 pivot block */ + + kp = k; + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &a[imax + (imax + 1) * + a_dim1], lda); + i__1 = imax + jmax * a_dim1; + rowmax = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(& + a[imax + jmax * a_dim1]), abs(r__2)); + } else { + rowmax = 0.f; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = icamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); + i__1 = itemp + imax * a_dim1; + stemp = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[ + itemp + imax * a_dim1]), abs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */ + + i__1 = imax + imax * a_dim1; + if (! ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[imax + + imax * a_dim1]), abs(r__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + done = TRUE_; + +/* Equivalent to testing for ROWMAX .EQ. COLMAX, */ +/* used to handle NaN and Inf */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot NOT found, set variables and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* Swap TWO rows and TWO columns */ + +/* First swap */ + + if (kstep == 2 && p != k) { + +/* Interchange rows and column K and P in the leading */ +/* submatrix A(1:k,1:k) if we have a 2-by-2 pivot */ + + if (p > 1) { + i__1 = p - 1; + cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + + 1], &c__1); + } + if (p < k - 1) { + i__1 = k - p - 1; + cswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + + 1) * a_dim1], lda); + } + i__1 = k + k * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = p + p * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = p + p * a_dim1; + a[i__1].r = t.r, a[i__1].i = t.i; + +/* Convert upper triangle of A into U form by applying */ +/* the interchanges in columns k+1:N. */ + + if (k < *n) { + i__1 = *n - k; + cswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k + + 1) * a_dim1], lda); + } + + } + +/* Second swap */ + + kk = k - kstep + 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + if (kp > 1) { + i__1 = kp - 1; + cswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (kk > 1 && kp < kk - 1) { + i__1 = kk - kp - 1; + cswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + ( + kp + 1) * a_dim1], lda); + } + i__1 = kk + kk * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + i__1 = kk + kk * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = t.r, a[i__1].i = t.i; + if (kstep == 2) { + i__1 = k - 1 + k * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + i__1 = k - 1 + k * a_dim1; + i__2 = kp + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + k * a_dim1; + a[i__1].r = t.r, a[i__1].i = t.i; + } + +/* Convert upper triangle of A into U form by applying */ +/* the interchanges in columns k+1:N. */ + + if (k < *n) { + i__1 = *n - k; + cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + + } + +/* Update the leading submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + + if (k > 1) { + +/* Perform a rank-1 update of A(1:k-1,1:k-1) and */ +/* store U(k) in column k */ + + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), abs(r__2)) >= sfmin) { + +/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ +/* A := A - U(k)*D(k)*U(k)**T */ +/* = A - W(k)*1/D(k)*W(k)**T */ + + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + d11.r = q__1.r, d11.i = q__1.i; + i__1 = k - 1; + q__1.r = -d11.r, q__1.i = -d11.i; + csyr_(uplo, &i__1, &q__1, &a[k * a_dim1 + 1], &c__1, & + a[a_offset], lda); + +/* Store U(k) in column k */ + + i__1 = k - 1; + cscal_(&i__1, &d11, &a[k * a_dim1 + 1], &c__1); + } else { + +/* Store L(k) in column K */ + + i__1 = k + k * a_dim1; + d11.r = a[i__1].r, d11.i = a[i__1].i; + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &d11); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L16: */ + } + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - U(k)*D(k)*U(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ +/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */ + + i__1 = k - 1; + q__1.r = -d11.r, q__1.i = -d11.i; + csyr_(uplo, &i__1, &q__1, &a[k * a_dim1 + 1], &c__1, & + a[a_offset], lda); + } + +/* Store the superdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ + +/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T */ +/* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T */ + +/* and store L(k) and L(k+1) in columns k and k+1 */ + + if (k > 2) { + + i__1 = k - 1 + k * a_dim1; + d12.r = a[i__1].r, d12.i = a[i__1].i; + c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &d12); + d22.r = q__1.r, d22.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &d12); + d11.r = q__1.r, d11.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + + for (j = k - 2; j >= 1; --j) { + + i__1 = j + (k - 1) * a_dim1; + q__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i, + q__3.i = d11.r * a[i__1].i + d11.i * a[i__1] + .r; + i__2 = j + k * a_dim1; + q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + .i; + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + wkm1.r = q__1.r, wkm1.i = q__1.i; + i__1 = j + k * a_dim1; + q__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i, + q__3.i = d22.r * a[i__1].i + d22.i * a[i__1] + .r; + i__2 = j + (k - 1) * a_dim1; + q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + .i; + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + wk.r = q__1.r, wk.i = q__1.i; + + for (i__ = j; i__ >= 1; --i__) { + i__1 = i__ + j * a_dim1; + i__2 = i__ + j * a_dim1; + c_div(&q__4, &a[i__ + k * a_dim1], &d12); + q__3.r = q__4.r * wk.r - q__4.i * wk.i, q__3.i = + q__4.r * wk.i + q__4.i * wk.r; + q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i - + q__3.i; + c_div(&q__6, &a[i__ + (k - 1) * a_dim1], &d12); + q__5.r = q__6.r * wkm1.r - q__6.i * wkm1.i, + q__5.i = q__6.r * wkm1.i + q__6.i * + wkm1.r; + q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - + q__5.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; +/* L20: */ + } + +/* Store U(k) and U(k-1) in cols k and k-1 for row J */ + + i__1 = j + k * a_dim1; + c_div(&q__1, &wk, &d12); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = j + (k - 1) * a_dim1; + c_div(&q__1, &wkm1, &d12); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* L30: */ + } + + } + +/* Copy superdiagonal elements of D(K) to E(K) and */ +/* ZERO out superdiagonal entry of A */ + + i__1 = k; + i__2 = k - 1 + k * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = k - 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = k - 1 + k * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L34: + + ; + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* Initialize the unused last entry of the subdiagonal array E. */ + + i__1 = *n; + e[i__1].r = 0.f, e[i__1].i = 0.f; + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; +L40: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L64; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * a_dim1; + absakk = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + k * + a_dim1]), abs(r__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1); + i__1 = imax + k * a_dim1; + colmax = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[imax + + k * a_dim1]), abs(r__2)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + +/* Set E( K ) to zero */ + + if (k < *n) { + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + } + + } else { + +/* Test for interchange */ + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABSAKK.GE.ALPHA*COLMAX */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L42: + +/* Begin pivot search loop body */ + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &a[imax + k * a_dim1], lda); + i__1 = imax + jmax * a_dim1; + rowmax = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(& + a[imax + jmax * a_dim1]), abs(r__2)); + } else { + rowmax = 0.f; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + icamax_(&i__1, &a[imax + 1 + imax * a_dim1] + , &c__1); + i__1 = itemp + imax * a_dim1; + stemp = (r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[ + itemp + imax * a_dim1]), abs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for (used to handle NaN and Inf) */ +/* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */ + + i__1 = imax + imax * a_dim1; + if (! ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[imax + + imax * a_dim1]), abs(r__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + done = TRUE_; + +/* Equivalent to testing for ROWMAX .EQ. COLMAX, */ +/* used to handle NaN and Inf */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot NOT found, set variables and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + } + +/* End pivot search loop body */ + + if (! done) { + goto L42; + } + + } + +/* Swap TWO rows and TWO columns */ + +/* First swap */ + + if (kstep == 2 && p != k) { + +/* Interchange rows and column K and P in the trailing */ +/* submatrix A(k:n,k:n) if we have a 2-by-2 pivot */ + + if (p < *n) { + i__1 = *n - p; + cswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p + * a_dim1], &c__1); + } + if (p > k + 1) { + i__1 = p - k - 1; + cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + + 1) * a_dim1], lda); + } + i__1 = k + k * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = p + p * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = p + p * a_dim1; + a[i__1].r = t.r, a[i__1].i = t.i; + +/* Convert lower triangle of A into L form by applying */ +/* the interchanges in columns 1:k-1. */ + + if (k > 1) { + i__1 = k - 1; + cswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + } + + } + +/* Second swap */ + + kk = k + kstep - 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the trailing */ +/* submatrix A(k:n,k:n) */ + + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (kk < *n && kp > kk + 1) { + i__1 = kp - kk - 1; + cswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + ( + kk + 1) * a_dim1], lda); + } + i__1 = kk + kk * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + i__1 = kk + kk * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = t.r, a[i__1].i = t.i; + if (kstep == 2) { + i__1 = k + 1 + k * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + i__1 = k + 1 + k * a_dim1; + i__2 = kp + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + k * a_dim1; + a[i__1].r = t.r, a[i__1].i = t.i; + } + +/* Convert lower triangle of A into L form by applying */ +/* the interchanges in columns 1:k-1. */ + + if (k > 1) { + i__1 = k - 1; + cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + + } + +/* Update the trailing submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + + if (k < *n) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) and */ +/* store L(k) in column k */ + + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, abs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), abs(r__2)) >= sfmin) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - L(k)*D(k)*L(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ + + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + d11.r = q__1.r, d11.i = q__1.i; + i__1 = *n - k; + q__1.r = -d11.r, q__1.i = -d11.i; + csyr_(uplo, &i__1, &q__1, &a[k + 1 + k * a_dim1], & + c__1, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Store L(k) in column k */ + + i__1 = *n - k; + cscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1); + } else { + +/* Store L(k) in column k */ + + i__1 = k + k * a_dim1; + d11.r = a[i__1].r, d11.i = a[i__1].i; + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &d11); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L46: */ + } + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ +/* A := A - L(k)*D(k)*L(k)**T */ +/* = A - W(k)*(1/D(k))*W(k)**T */ +/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */ + + i__1 = *n - k; + q__1.r = -d11.r, q__1.i = -d11.i; + csyr_(uplo, &i__1, &q__1, &a[k + 1 + k * a_dim1], & + c__1, &a[k + 1 + (k + 1) * a_dim1], lda); + } + +/* Store the subdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0.f, e[i__1].i = 0.f; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + +/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ + +/* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T */ +/* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T */ + +/* and store L(k) and L(k+1) in columns k and k+1 */ + + if (k < *n - 1) { + + i__1 = k + 1 + k * a_dim1; + d21.r = a[i__1].r, d21.i = a[i__1].i; + c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + +/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ + + i__2 = j + k * a_dim1; + q__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i, + q__3.i = d11.r * a[i__2].i + d11.i * a[i__2] + .r; + i__3 = j + (k + 1) * a_dim1; + q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + .i; + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + wk.r = q__1.r, wk.i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + q__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i, + q__3.i = d22.r * a[i__2].i + d22.i * a[i__2] + .r; + i__3 = j + k * a_dim1; + q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + .i; + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + wkp1.r = q__1.r, wkp1.i = q__1.i; + +/* Perform a rank-2 update of A(k+2:n,k+2:n) */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + c_div(&q__4, &a[i__ + k * a_dim1], &d21); + q__3.r = q__4.r * wk.r - q__4.i * wk.i, q__3.i = + q__4.r * wk.i + q__4.i * wk.r; + q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - + q__3.i; + c_div(&q__6, &a[i__ + (k + 1) * a_dim1], &d21); + q__5.r = q__6.r * wkp1.r - q__6.i * wkp1.i, + q__5.i = q__6.r * wkp1.i + q__6.i * + wkp1.r; + q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - + q__5.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L50: */ + } + +/* Store L(k) and L(k+1) in cols k and k+1 for row J */ + + i__2 = j + k * a_dim1; + c_div(&q__1, &wk, &d21); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + c_div(&q__1, &wkp1, &d21); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + +/* L60: */ + } + + } + +/* Copy subdiagonal elements of D(K) to E(K) and */ +/* ZERO out subdiagonal entry of A */ + + i__1 = k; + i__2 = k + 1 + k * a_dim1; + e[i__1].r = a[i__2].r, e[i__1].i = a[i__2].i; + i__1 = k + 1; + e[i__1].r = 0.f, e[i__1].i = 0.f; + i__1 = k + 1 + k * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L40; + +L64: + + ; + } + + return 0; + +/* End of CSYTF2_RK */ + +} /* csytf2_rk__ */ +