From 62e3b480bf319683b80aae79e3defbde8267cfeb Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 23 Feb 2022 00:11:44 +0100 Subject: [PATCH] Add C versions as fallback --- lapack-netlib/SRC/csytf2.c | 1169 ++++++++++++++++++++ lapack-netlib/SRC/csytf2_rook.c | 1408 ++++++++++++++++++++++++ lapack-netlib/SRC/csytrf.c | 780 +++++++++++++ lapack-netlib/SRC/csytrf_aa.c | 918 ++++++++++++++++ lapack-netlib/SRC/csytrf_aa_2stage.c | 1161 ++++++++++++++++++++ lapack-netlib/SRC/csytrf_rk.c | 920 ++++++++++++++++ lapack-netlib/SRC/csytrf_rook.c | 811 ++++++++++++++ lapack-netlib/SRC/csytri.c | 916 ++++++++++++++++ lapack-netlib/SRC/csytri2.c | 607 +++++++++++ lapack-netlib/SRC/csytri2x.c | 1257 +++++++++++++++++++++ lapack-netlib/SRC/csytri_3.c | 649 +++++++++++ lapack-netlib/SRC/csytri_3x.c | 1306 ++++++++++++++++++++++ lapack-netlib/SRC/csytri_rook.c | 1021 +++++++++++++++++ lapack-netlib/SRC/csytrs.c | 934 ++++++++++++++++ lapack-netlib/SRC/csytrs2.c | 820 ++++++++++++++ lapack-netlib/SRC/csytrs_3.c | 817 ++++++++++++++ lapack-netlib/SRC/csytrs_aa.c | 739 +++++++++++++ lapack-netlib/SRC/csytrs_aa_2stage.c | 690 ++++++++++++ lapack-netlib/SRC/csytrs_rook.c | 976 +++++++++++++++++ lapack-netlib/SRC/ctbcon.c | 686 ++++++++++++ lapack-netlib/SRC/ctbrfs.c | 1033 ++++++++++++++++++ lapack-netlib/SRC/ctbtrs.c | 646 +++++++++++ lapack-netlib/SRC/ctfsm.c | 1464 +++++++++++++++++++++++++ lapack-netlib/SRC/ctftri.c | 924 ++++++++++++++++ lapack-netlib/SRC/ctfttp.c | 996 +++++++++++++++++ lapack-netlib/SRC/ctfttr.c | 1006 +++++++++++++++++ lapack-netlib/SRC/ctgevc.c | 1428 ++++++++++++++++++++++++ lapack-netlib/SRC/ctgex2.c | 828 ++++++++++++++ lapack-netlib/SRC/ctgexc.c | 704 ++++++++++++ lapack-netlib/SRC/ctgsen.c | 1255 +++++++++++++++++++++ lapack-netlib/SRC/ctgsja.c | 1168 ++++++++++++++++++++ lapack-netlib/SRC/ctgsna.c | 963 ++++++++++++++++ lapack-netlib/SRC/ctgsy2.c | 941 ++++++++++++++++ lapack-netlib/SRC/ctgsyl.c | 1172 ++++++++++++++++++++ lapack-netlib/SRC/ctpcon.c | 665 ++++++++++++ lapack-netlib/SRC/ctplqt.c | 664 ++++++++++++ lapack-netlib/SRC/ctplqt2.c | 787 ++++++++++++++ lapack-netlib/SRC/ctpmlqt.c | 771 +++++++++++++ lapack-netlib/SRC/ctpmqrt.c | 791 ++++++++++++++ lapack-netlib/SRC/ctpqrt.c | 682 ++++++++++++ lapack-netlib/SRC/ctpqrt2.c | 754 +++++++++++++ lapack-netlib/SRC/ctprfb.c | 1505 ++++++++++++++++++++++++++ lapack-netlib/SRC/ctprfs.c | 1002 +++++++++++++++++ lapack-netlib/SRC/ctptri.c | 660 +++++++++++ lapack-netlib/SRC/ctptrs.c | 628 +++++++++++ lapack-netlib/SRC/ctpttf.c | 996 +++++++++++++++++ lapack-netlib/SRC/ctpttr.c | 571 ++++++++++ lapack-netlib/SRC/ctrcon.c | 678 ++++++++++++ lapack-netlib/SRC/ctrevc.c | 983 +++++++++++++++++ lapack-netlib/SRC/ctrevc3.c | 1164 ++++++++++++++++++++ lapack-netlib/SRC/ctrexc.c | 653 +++++++++++ lapack-netlib/SRC/ctrrfs.c | 1008 +++++++++++++++++ lapack-netlib/SRC/ctrsen.c | 873 +++++++++++++++ lapack-netlib/SRC/ctrsna.c | 904 ++++++++++++++++ lapack-netlib/SRC/ctrsyl.c | 984 +++++++++++++++++ lapack-netlib/SRC/ctrti2.c | 619 +++++++++++ lapack-netlib/SRC/ctrtri.c | 668 ++++++++++++ lapack-netlib/SRC/ctrtrs.c | 621 +++++++++++ lapack-netlib/SRC/ctrttf.c | 1006 +++++++++++++++++ lapack-netlib/SRC/ctrttp.c | 571 ++++++++++ lapack-netlib/SRC/ctzrzf.c | 739 +++++++++++++ lapack-netlib/SRC/cunbdb.c | 1305 ++++++++++++++++++++++ lapack-netlib/SRC/cunbdb1.c | 779 +++++++++++++ lapack-netlib/SRC/cunbdb2.c | 797 ++++++++++++++ lapack-netlib/SRC/cunbdb3.c | 793 ++++++++++++++ lapack-netlib/SRC/cunbdb4.c | 864 +++++++++++++++ lapack-netlib/SRC/cunbdb5.c | 679 ++++++++++++ lapack-netlib/SRC/cunbdb6.c | 733 +++++++++++++ lapack-netlib/SRC/cuncsd.c | 1206 +++++++++++++++++++++ lapack-netlib/SRC/cuncsd2by1.c | 1357 +++++++++++++++++++++++ lapack-netlib/SRC/cung2l.c | 615 +++++++++++ lapack-netlib/SRC/cung2r.c | 615 +++++++++++ lapack-netlib/SRC/cungbr.c | 767 +++++++++++++ lapack-netlib/SRC/cunghr.c | 658 +++++++++++ lapack-netlib/SRC/cungl2.c | 622 +++++++++++ lapack-netlib/SRC/cunglq.c | 720 ++++++++++++ lapack-netlib/SRC/cungql.c | 730 +++++++++++++ lapack-netlib/SRC/cungqr.c | 721 ++++++++++++ lapack-netlib/SRC/cungr2.c | 622 +++++++++++ lapack-netlib/SRC/cungrq.c | 730 +++++++++++++ lapack-netlib/SRC/cungtr.c | 693 ++++++++++++ lapack-netlib/SRC/cungtsqr.c | 718 ++++++++++++ lapack-netlib/SRC/cungtsqr_row.c | 800 ++++++++++++++ lapack-netlib/SRC/cunhr_col.c | 861 +++++++++++++++ lapack-netlib/SRC/cunm22.c | 864 +++++++++++++++ lapack-netlib/SRC/cunm2l.c | 687 ++++++++++++ lapack-netlib/SRC/cunm2r.c | 691 ++++++++++++ lapack-netlib/SRC/cunmbr.c | 821 ++++++++++++++ lapack-netlib/SRC/cunmhr.c | 709 ++++++++++++ lapack-netlib/SRC/cunml2.c | 696 ++++++++++++ lapack-netlib/SRC/cunmlq.c | 779 +++++++++++++ lapack-netlib/SRC/cunmql.c | 767 +++++++++++++ lapack-netlib/SRC/cunmqr.c | 766 +++++++++++++ lapack-netlib/SRC/cunmr2.c | 688 ++++++++++++ lapack-netlib/SRC/cunmr3.c | 706 ++++++++++++ lapack-netlib/SRC/cunmrq.c | 773 +++++++++++++ lapack-netlib/SRC/cunmrz.c | 814 ++++++++++++++ lapack-netlib/SRC/cunmtr.c | 744 +++++++++++++ lapack-netlib/SRC/cupgtr.c | 651 +++++++++++ lapack-netlib/SRC/cupmtr.c | 759 +++++++++++++ 100 files changed, 85360 insertions(+) create mode 100644 lapack-netlib/SRC/csytf2.c create mode 100644 lapack-netlib/SRC/csytf2_rook.c create mode 100644 lapack-netlib/SRC/csytrf.c create mode 100644 lapack-netlib/SRC/csytrf_aa.c create mode 100644 lapack-netlib/SRC/csytrf_aa_2stage.c create mode 100644 lapack-netlib/SRC/csytrf_rk.c create mode 100644 lapack-netlib/SRC/csytrf_rook.c create mode 100644 lapack-netlib/SRC/csytri.c create mode 100644 lapack-netlib/SRC/csytri2.c create mode 100644 lapack-netlib/SRC/csytri2x.c create mode 100644 lapack-netlib/SRC/csytri_3.c create mode 100644 lapack-netlib/SRC/csytri_3x.c create mode 100644 lapack-netlib/SRC/csytri_rook.c create mode 100644 lapack-netlib/SRC/csytrs.c create mode 100644 lapack-netlib/SRC/csytrs2.c create mode 100644 lapack-netlib/SRC/csytrs_3.c create mode 100644 lapack-netlib/SRC/csytrs_aa.c create mode 100644 lapack-netlib/SRC/csytrs_aa_2stage.c create mode 100644 lapack-netlib/SRC/csytrs_rook.c create mode 100644 lapack-netlib/SRC/ctbcon.c create mode 100644 lapack-netlib/SRC/ctbrfs.c create mode 100644 lapack-netlib/SRC/ctbtrs.c create mode 100644 lapack-netlib/SRC/ctfsm.c create mode 100644 lapack-netlib/SRC/ctftri.c create mode 100644 lapack-netlib/SRC/ctfttp.c create mode 100644 lapack-netlib/SRC/ctfttr.c create mode 100644 lapack-netlib/SRC/ctgevc.c create mode 100644 lapack-netlib/SRC/ctgex2.c create mode 100644 lapack-netlib/SRC/ctgexc.c create mode 100644 lapack-netlib/SRC/ctgsen.c create mode 100644 lapack-netlib/SRC/ctgsja.c create mode 100644 lapack-netlib/SRC/ctgsna.c create mode 100644 lapack-netlib/SRC/ctgsy2.c create mode 100644 lapack-netlib/SRC/ctgsyl.c create mode 100644 lapack-netlib/SRC/ctpcon.c create mode 100644 lapack-netlib/SRC/ctplqt.c create mode 100644 lapack-netlib/SRC/ctplqt2.c create mode 100644 lapack-netlib/SRC/ctpmlqt.c create mode 100644 lapack-netlib/SRC/ctpmqrt.c create mode 100644 lapack-netlib/SRC/ctpqrt.c create mode 100644 lapack-netlib/SRC/ctpqrt2.c create mode 100644 lapack-netlib/SRC/ctprfb.c create mode 100644 lapack-netlib/SRC/ctprfs.c create mode 100644 lapack-netlib/SRC/ctptri.c create mode 100644 lapack-netlib/SRC/ctptrs.c create mode 100644 lapack-netlib/SRC/ctpttf.c create mode 100644 lapack-netlib/SRC/ctpttr.c create mode 100644 lapack-netlib/SRC/ctrcon.c create mode 100644 lapack-netlib/SRC/ctrevc.c create mode 100644 lapack-netlib/SRC/ctrevc3.c create mode 100644 lapack-netlib/SRC/ctrexc.c create mode 100644 lapack-netlib/SRC/ctrrfs.c create mode 100644 lapack-netlib/SRC/ctrsen.c create mode 100644 lapack-netlib/SRC/ctrsna.c create mode 100644 lapack-netlib/SRC/ctrsyl.c create mode 100644 lapack-netlib/SRC/ctrti2.c create mode 100644 lapack-netlib/SRC/ctrtri.c create mode 100644 lapack-netlib/SRC/ctrtrs.c create mode 100644 lapack-netlib/SRC/ctrttf.c create mode 100644 lapack-netlib/SRC/ctrttp.c create mode 100644 lapack-netlib/SRC/ctzrzf.c create mode 100644 lapack-netlib/SRC/cunbdb.c create mode 100644 lapack-netlib/SRC/cunbdb1.c create mode 100644 lapack-netlib/SRC/cunbdb2.c create mode 100644 lapack-netlib/SRC/cunbdb3.c create mode 100644 lapack-netlib/SRC/cunbdb4.c create mode 100644 lapack-netlib/SRC/cunbdb5.c create mode 100644 lapack-netlib/SRC/cunbdb6.c create mode 100644 lapack-netlib/SRC/cuncsd.c create mode 100644 lapack-netlib/SRC/cuncsd2by1.c create mode 100644 lapack-netlib/SRC/cung2l.c create mode 100644 lapack-netlib/SRC/cung2r.c create mode 100644 lapack-netlib/SRC/cungbr.c create mode 100644 lapack-netlib/SRC/cunghr.c create mode 100644 lapack-netlib/SRC/cungl2.c create mode 100644 lapack-netlib/SRC/cunglq.c create mode 100644 lapack-netlib/SRC/cungql.c create mode 100644 lapack-netlib/SRC/cungqr.c create mode 100644 lapack-netlib/SRC/cungr2.c create mode 100644 lapack-netlib/SRC/cungrq.c create mode 100644 lapack-netlib/SRC/cungtr.c create mode 100644 lapack-netlib/SRC/cungtsqr.c create mode 100644 lapack-netlib/SRC/cungtsqr_row.c create mode 100644 lapack-netlib/SRC/cunhr_col.c create mode 100644 lapack-netlib/SRC/cunm22.c create mode 100644 lapack-netlib/SRC/cunm2l.c create mode 100644 lapack-netlib/SRC/cunm2r.c create mode 100644 lapack-netlib/SRC/cunmbr.c create mode 100644 lapack-netlib/SRC/cunmhr.c create mode 100644 lapack-netlib/SRC/cunml2.c create mode 100644 lapack-netlib/SRC/cunmlq.c create mode 100644 lapack-netlib/SRC/cunmql.c create mode 100644 lapack-netlib/SRC/cunmqr.c create mode 100644 lapack-netlib/SRC/cunmr2.c create mode 100644 lapack-netlib/SRC/cunmr3.c create mode 100644 lapack-netlib/SRC/cunmrq.c create mode 100644 lapack-netlib/SRC/cunmrz.c create mode 100644 lapack-netlib/SRC/cunmtr.c create mode 100644 lapack-netlib/SRC/cupgtr.c create mode 100644 lapack-netlib/SRC/cupmtr.c diff --git a/lapack-netlib/SRC/csytf2.c b/lapack-netlib/SRC/csytf2.c new file mode 100644 index 000000000..43171b6ce --- /dev/null +++ b/lapack-netlib/SRC/csytf2.c @@ -0,0 +1,1169 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal piv +oting method (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTF2 computes the factorization of a complex symmetric matrix A */ +/* > using the Bunch-Kaufman diagonal pivoting method: */ +/* > */ +/* > A = U*D*U**T or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, U**T is the transpose of U, and D is symmetric and */ +/* > block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is 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, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = IPIV(k-1) < 0, then rows and columns */ +/* > k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = IPIV(k+1) < 0, then rows and columns */ +/* > k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) */ +/* > is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 09-29-06 - patch from */ +/* > Bobby Cheng, MathWorks */ +/* > */ +/* > Replace l.209 and l.377 */ +/* > IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */ +/* > by */ +/* > IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN */ +/* > */ +/* > 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */ +/* > Company */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csytf2_(char *uplo, integer *n, complex *a, integer *lda, + integer *ipiv, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, 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 csyr_(char *, integer *, complex *, complex *, + integer *, complex *, integer *); + 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 kk, kp; + real absakk; + complex wk; + extern integer icamax_(integer *, complex *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real colmax; + extern logical sisnan_(real *); + real 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; + --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", &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; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L70; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + 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 || sisnan_(&absakk)) { + +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = k - imax; + jmax = imax + 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)); + if (imax > 1) { + i__1 = imax - 1; + jmax = icamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + imax * a_dim1; + r__3 = rowmax, r__4 = (r__1 = a[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&a[jmax + imax * a_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 + 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; + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + + kk = k - kstep + 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + i__1 = kp - 1; + cswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], + &c__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; + } + } + +/* 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, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = k - 1; + q__1.r = -r1.r, q__1.i = -r1.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, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + +/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ + +/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T */ +/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T */ + + if (k > 2) { + + 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; + 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 - 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 = 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 * 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 = 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 * a_dim1; + i__2 = i__ + j * a_dim1; + i__3 = i__ + k * a_dim1; + q__3.r = a[i__3].r * wk.r - a[i__3].i * wk.i, + q__3.i = a[i__3].r * wk.i + a[i__3].i * + wk.r; + q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i - + q__3.i; + i__4 = i__ + (k - 1) * a_dim1; + q__4.r = a[i__4].r * wkm1.r - a[i__4].i * wkm1.i, + q__4.i = a[i__4].r * wkm1.i + a[i__4].i * + wkm1.r; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; +/* L20: */ + } + i__1 = j + k * a_dim1; + a[i__1].r = wk.r, a[i__1].i = wk.i; + i__1 = j + (k - 1) * a_dim1; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; +/* L30: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; +L40: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L70; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + 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 || sisnan_(&absakk)) { + +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = imax - k; + jmax = k - 1 + 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)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + icamax_(&i__1, &a[imax + 1 + imax * a_dim1], + &c__1); +/* Computing MAX */ + i__1 = jmax + imax * a_dim1; + r__3 = rowmax, r__4 = (r__1 = a[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&a[jmax + imax * a_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 + 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; + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + + kk = k + kstep - 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the trailing */ +/* submatrix A(k:n,k:n) */ + + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__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; + } + } + +/* 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, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = *n - k; + q__1.r = -r1.r, q__1.i = -r1.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, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + +/* 2-by-2 pivot block D(k) */ + + if (k < *n - 1) { + +/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ + +/* A := A - ( 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 * 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; + 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 * 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 = 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 + 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 = 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 * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + k * a_dim1; + q__3.r = a[i__5].r * wk.r - a[i__5].i * wk.i, + q__3.i = a[i__5].r * wk.i + a[i__5].i * + wk.r; + q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - + q__3.i; + i__6 = i__ + (k + 1) * a_dim1; + q__4.r = a[i__6].r * wkp1.r - a[i__6].i * wkp1.i, + q__4.i = a[i__6].r * wkp1.i + a[i__6].i * + wkp1.r; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L50: */ + } + i__2 = j + k * a_dim1; + a[i__2].r = wk.r, a[i__2].i = wk.i; + i__2 = j + (k + 1) * a_dim1; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; +/* L60: */ + } + } + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L40; + + } + +L70: + return 0; + +/* End of CSYTF2 */ + +} /* csytf2_ */ + diff --git a/lapack-netlib/SRC/csytf2_rook.c b/lapack-netlib/SRC/csytf2_rook.c new file mode 100644 index 000000000..83c710dec --- /dev/null +++ b/lapack-netlib/SRC/csytf2_rook.c @@ -0,0 +1,1408 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + 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_ROOK computes the factorization of a complex symmetric indefinite matrix using the bound +ed Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTF2_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTF2_ROOK computes the factorization of a complex symmetric matrix A */ +/* > using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: */ +/* > */ +/* > A = U*D*U**T or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, U**T is the transpose of U, and D is symmetric and */ +/* > block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is 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, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > 01-01-96 - Based on modifications by */ +/* > J. Lewis, Boeing Computer Services Company */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csytf2_rook_(char *uplo, integer *n, complex *a, + integer *lda, 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.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTF2_ROOK", &i__1, (ftnlen)11); + 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 */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2 */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L70; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + 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; + } 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) */ +/* CABS1( 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; + } + +/* 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; + } + } + +/* 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); + } + } + + } 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: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; +L40: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L70; + } + kstep = 1; + p = k; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + 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; + } 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) */ +/* CABS1( 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; + } + +/* 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; + } + } + +/* 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); + } + } + + } 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: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L40; + + } + +L70: + + return 0; + +/* End of CSYTF2_ROOK */ + +} /* csytf2_rook__ */ + diff --git a/lapack-netlib/SRC/csytrf.c b/lapack-netlib/SRC/csytrf.c new file mode 100644 index 000000000..baad9e445 --- /dev/null +++ b/lapack-netlib/SRC/csytrf.c @@ -0,0 +1,780 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRF computes the factorization of a complex symmetric matrix A */ +/* > using the Bunch-Kaufman diagonal pivoting method. The form of the */ +/* > factorization is */ +/* > */ +/* > A = U*D*U**T or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* > columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* > IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* > interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >=1. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned by ILAENV. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int csytrf_(char *uplo, integer *n, complex *a, integer *lda, + integer *ipiv, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j, k; + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + logical upper; + extern /* Subroutine */ int csytf2_(char *, integer *, complex *, integer + *, integer *, integer *); + integer kb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int clasyf_(char *, integer *, integer *, integer + *, complex *, integer *, integer *, complex *, integer *, integer + *); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -7; + } + + if (*info == 0) { + +/* Determine the block size */ + + nb = ilaenv_(&c__1, "CSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *n * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { + iws = ldwork * nb; + if (*lwork < iws) { +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = f2cmax(i__1,1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CSYTRF", uplo, n, &c_n1, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } else { + iws = 1; + } + if (nb < nbmin) { + nb = *n; + } + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* KB, where KB is the number of columns factorized by CLASYF; */ +/* KB is either NB or NB-1, or K for the last block */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L40; + } + + if (k > nb) { + +/* Factorize columns k-kb+1:k of A and use blocked code to */ +/* update columns 1:k-kb */ + + clasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], + n, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + csytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo); + kb = k; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kb; + goto L10; + + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* KB, where KB is the number of columns factorized by CLASYF; */ +/* KB is either NB or NB-1, or N-K+1 for the last block */ + + k = 1; +L20: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L40; + } + + if (k <= *n - nb) { + +/* Factorize columns k:k+kb-1 of A and use blocked code to */ +/* update columns k+kb:n */ + + i__1 = *n - k + 1; + clasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], + &work[1], n, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + csytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo); + kb = *n - k + 1; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + k - 1; + } + +/* Adjust IPIV */ + + i__1 = k + kb - 1; + for (j = k; j <= i__1; ++j) { + if (ipiv[j] > 0) { + ipiv[j] = ipiv[j] + k - 1; + } else { + ipiv[j] = ipiv[j] - k + 1; + } +/* L30: */ + } + +/* Increase K and return to the start of the main loop */ + + k += kb; + goto L20; + + } + +L40: + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CSYTRF */ + +} /* csytrf_ */ + diff --git a/lapack-netlib/SRC/csytrf_aa.c b/lapack-netlib/SRC/csytrf_aa.c new file mode 100644 index 000000000..1095c25ff --- /dev/null +++ b/lapack-netlib/SRC/csytrf_aa.c @@ -0,0 +1,918 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRF_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRF_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LWORK, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRF_AA computes the factorization of a complex symmetric matrix A */ +/* > using the Aasen's algorithm. The form of the factorization is */ +/* > */ +/* > A = U**T*T*U or A = L*T*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is a complex symmetric tridiagonal matrix. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the tridiagonal matrix is stored in the diagonals */ +/* > and the subdiagonals of A just below (or above) the diagonals, */ +/* > and L is stored below (or above) the subdiaonals, when UPLO */ +/* > is 'L' (or 'U'). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > On exit, it contains the details of the interchanges, i.e., */ +/* > the row and column k of A were interchanged with the */ +/* > row and column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= MAX(1,2*N). For optimum performance */ +/* > LWORK >= N*(1+NB), where NB is the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytrf_aa_(char *uplo, integer *n, complex *a, integer * + lda, integer *ipiv, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer j; + complex 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 clasyf_aa_(char *, integer *, integer *, + integer *, complex *, integer *, integer *, complex *, integer *, + complex *), cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), cswap_(integer *, complex *, integer *, + complex *, integer *), ccopy_(integer *, complex *, integer *, + complex *, integer *); + logical upper; + integer k1, k2, j1, j2, j3, jb, nb, mj, nj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + +/* Determine the block size */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + nb = ilaenv_(&c__1, "CSYTRF_AA", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)9, + (ftnlen)1); + +/* Test the input parameters. */ + + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 1; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -7; + } + } + + if (*info == 0) { + lwkopt = (nb + 1) * *n; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRF_AA", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return */ + + if (*n == 0) { + return 0; + } + ipiv[1] = 1; + if (*n == 1) { + return 0; + } + +/* Adjust block size based on the workspace size */ + + if (*lwork < (nb + 1) * *n) { + nb = (*lwork - *n) / *n; + } + + if (upper) { + +/* ..................................................... */ +/* Factorize A as U**T*D*U using the upper triangle of A */ +/* ..................................................... */ + +/* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) */ + + ccopy_(n, &a[a_dim1 + 1], lda, &work[1], &c__1); + +/* J is the main loop index, increasing from 1 to N in steps of */ +/* JB, where JB is the number of columns factorized by CLASYF; */ +/* JB is either NB, or N-J+1 for the last block */ + + j = 0; +L10: + if (j >= *n) { + goto L20; + } + +/* each step of the main loop */ +/* J is the last column of the previous panel */ +/* J1 is the first column of the current panel */ +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 for the first panel, and */ +/* K1=0 for the rest */ + + j1 = j + 1; +/* Computing MIN */ + i__1 = *n - j1 + 1; + jb = f2cmin(i__1,nb); + k1 = f2cmax(1,j) - j; + +/* Panel factorization */ + + i__1 = 2 - k1; + i__2 = *n - j; + clasyf_aa_(uplo, &i__1, &i__2, &jb, &a[f2cmax(1,j) + (j + 1) * a_dim1], + lda, &ipiv[j + 1], &work[1], n, &work[*n * nb + 1]) + ; + +/* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot) */ + +/* Computing MIN */ + i__2 = *n, i__3 = j + jb + 1; + i__1 = f2cmin(i__2,i__3); + for (j2 = j + 2; j2 <= i__1; ++j2) { + ipiv[j2] += j; + if (j2 != ipiv[j2] && j1 - k1 > 2) { + i__2 = j1 - k1 - 2; + cswap_(&i__2, &a[j2 * a_dim1 + 1], &c__1, &a[ipiv[j2] * + a_dim1 + 1], &c__1); + } + } + j += jb; + +/* Trailing submatrix update, where */ +/* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and */ +/* WORK stores the current block of the auxiriarly matrix H */ + + if (j < *n) { + +/* If first panel and JB=1 (NB=1), then nothing to do */ + + if (j1 > 1 || jb > 1) { + +/* Merge rank-1 update with BLAS-3 update */ + + i__1 = j + (j + 1) * a_dim1; + alpha.r = a[i__1].r, alpha.i = a[i__1].i; + i__1 = j + (j + 1) * a_dim1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + i__1 = *n - j; + ccopy_(&i__1, &a[j - 1 + (j + 1) * a_dim1], lda, &work[j + 1 + - j1 + 1 + jb * *n], &c__1); + i__1 = *n - j; + cscal_(&i__1, &alpha, &work[j + 1 - j1 + 1 + jb * *n], &c__1); + +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, */ +/* while K1=0 and K2=1 for the rest */ + + if (j1 > 1) { + +/* Not first panel */ + + k2 = 1; + } else { + +/* First panel */ + + k2 = 0; + +/* First update skips the first column */ + + --jb; + } + + i__1 = *n; + i__2 = nb; + for (j2 = j + 1; i__2 < 0 ? j2 >= i__1 : j2 <= i__1; j2 += + i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - j2 + 1; + nj = f2cmin(i__3,i__4); + +/* Update (J2, J2) diagonal block with CGEMV */ + + j3 = j2; + for (mj = nj - 1; mj >= 1; --mj) { + i__3 = jb + 1; + cgemv_("No transpose", &mj, &i__3, &c_b19, &work[j3 - + j1 + 1 + k1 * *n], n, &a[j1 - k2 + j3 * + a_dim1], &c__1, &c_b15, &a[j3 + j3 * a_dim1], + lda); + ++j3; + } + +/* Update off-diagonal block of J2-th block row with CGEMM */ + + i__3 = *n - j3 + 1; + i__4 = jb + 1; + cgemm_("Transpose", "Transpose", &nj, &i__3, &i__4, & + c_b19, &a[j1 - k2 + j2 * a_dim1], lda, &work[j3 - + j1 + 1 + k1 * *n], n, &c_b15, &a[j2 + j3 * a_dim1] + , lda); + } + +/* Recover T( J, J+1 ) */ + + i__2 = j + (j + 1) * a_dim1; + a[i__2].r = alpha.r, a[i__2].i = alpha.i; + } + +/* WORK(J+1, 1) stores H(J+1, 1) */ + + i__2 = *n - j; + ccopy_(&i__2, &a[j + 1 + (j + 1) * a_dim1], lda, &work[1], &c__1); + } + goto L10; + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T using the lower triangle of A */ +/* ..................................................... */ + +/* copy first column A(1:N, 1) into H(1:N, 1) */ +/* (stored in WORK(1:N)) */ + + ccopy_(n, &a[a_dim1 + 1], &c__1, &work[1], &c__1); + +/* J is the main loop index, increasing from 1 to N in steps of */ +/* JB, where JB is the number of columns factorized by CLASYF; */ +/* JB is either NB, or N-J+1 for the last block */ + + j = 0; +L11: + if (j >= *n) { + goto L20; + } + +/* each step of the main loop */ +/* J is the last column of the previous panel */ +/* J1 is the first column of the current panel */ +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 for the first panel, and */ +/* K1=0 for the rest */ + + j1 = j + 1; +/* Computing MIN */ + i__2 = *n - j1 + 1; + jb = f2cmin(i__2,nb); + k1 = f2cmax(1,j) - j; + +/* Panel factorization */ + + i__2 = 2 - k1; + i__1 = *n - j; + clasyf_aa_(uplo, &i__2, &i__1, &jb, &a[j + 1 + f2cmax(1,j) * a_dim1], + lda, &ipiv[j + 1], &work[1], n, &work[*n * nb + 1]) + ; + +/* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot) */ + +/* Computing MIN */ + i__1 = *n, i__3 = j + jb + 1; + i__2 = f2cmin(i__1,i__3); + for (j2 = j + 2; j2 <= i__2; ++j2) { + ipiv[j2] += j; + if (j2 != ipiv[j2] && j1 - k1 > 2) { + i__1 = j1 - k1 - 2; + cswap_(&i__1, &a[j2 + a_dim1], lda, &a[ipiv[j2] + a_dim1], + lda); + } + } + j += jb; + +/* Trailing submatrix update, where */ +/* A(J2+1, J1-1) stores L(J2+1, J1) and */ +/* WORK(J2+1, 1) stores H(J2+1, 1) */ + + if (j < *n) { + +/* if first panel and JB=1 (NB=1), then nothing to do */ + + if (j1 > 1 || jb > 1) { + +/* Merge rank-1 update with BLAS-3 update */ + + i__2 = j + 1 + j * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = j + 1 + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + i__2 = *n - j; + ccopy_(&i__2, &a[j + 1 + (j - 1) * a_dim1], &c__1, &work[j + + 1 - j1 + 1 + jb * *n], &c__1); + i__2 = *n - j; + cscal_(&i__2, &alpha, &work[j + 1 - j1 + 1 + jb * *n], &c__1); + +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, */ +/* while K1=0 and K2=1 for the rest */ + + if (j1 > 1) { + +/* Not first panel */ + + k2 = 1; + } else { + +/* First panel */ + + k2 = 0; + +/* First update skips the first column */ + + --jb; + } + + i__2 = *n; + i__1 = nb; + for (j2 = j + 1; i__1 < 0 ? j2 >= i__2 : j2 <= i__2; j2 += + i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - j2 + 1; + nj = f2cmin(i__3,i__4); + +/* Update (J2, J2) diagonal block with CGEMV */ + + j3 = j2; + for (mj = nj - 1; mj >= 1; --mj) { + i__3 = jb + 1; + cgemv_("No transpose", &mj, &i__3, &c_b19, &work[j3 - + j1 + 1 + k1 * *n], n, &a[j3 + (j1 - k2) * + a_dim1], lda, &c_b15, &a[j3 + j3 * a_dim1], & + c__1); + ++j3; + } + +/* Update off-diagonal block in J2-th block column with CGEMM */ + + i__3 = *n - j3 + 1; + i__4 = jb + 1; + cgemm_("No transpose", "Transpose", &i__3, &nj, &i__4, & + c_b19, &work[j3 - j1 + 1 + k1 * *n], n, &a[j2 + ( + j1 - k2) * a_dim1], lda, &c_b15, &a[j3 + j2 * + a_dim1], lda); + } + +/* Recover T( J+1, J ) */ + + i__1 = j + 1 + j * a_dim1; + a[i__1].r = alpha.r, a[i__1].i = alpha.i; + } + +/* WORK(J+1, 1) stores H(J+1, 1) */ + + i__1 = *n - j; + ccopy_(&i__1, &a[j + 1 + (j + 1) * a_dim1], &c__1, &work[1], & + c__1); + } + goto L11; + } + +L20: + return 0; + +/* End of CSYTRF_AA */ + +} /* csytrf_aa__ */ + diff --git a/lapack-netlib/SRC/csytrf_aa_2stage.c b/lapack-netlib/SRC/csytrf_aa_2stage.c new file mode 100644 index 000000000..80fbe267a --- /dev/null +++ b/lapack-netlib/SRC/csytrf_aa_2stage.c @@ -0,0 +1,1161 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRF_AA_2STAGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRF_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRF_AA_2STAGE( UPLO, N, A, LDA, TB, LTB, IPIV, */ +/* IPIV2, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LTB, LWORK, INFO */ +/* INTEGER IPIV( * ), IPIV2( * ) */ +/* COMPLEX A( LDA, * ), TB( * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRF_AA_2STAGE computes the factorization of a complex symmetric matrix A */ +/* > using the Aasen's algorithm. The form of the factorization is */ +/* > */ +/* > A = U**T*T*U or A = L*T*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is a complex symmetric band matrix with the */ +/* > bandwidth of NB (NB is internally selected and stored in TB( 1 ), and T is */ +/* > LU factorized with partial pivoting). */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is 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, 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[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 csytrf_aa_2stage_(char *uplo, integer *n, complex *a, + integer *lda, complex *tb, integer *ltb, integer *ipiv, integer * + ipiv2, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1; + + /* Local variables */ + integer ldtb, i__, j, k; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), cswap_(integer *, complex *, integer *, + complex *, integer *), ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer i1; + logical upper; + integer i2, jb, kb, nb, td, nt; + extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *, + integer *, complex *, integer *, integer *, integer *), cgetrf_( + integer *, integer *, complex *, integer *, integer *, integer *), + clacpy_(char *, integer *, integer *, complex *, integer *, + complex *, integer *), claset_(char *, integer *, integer + *, complex *, complex *, complex *, integer *), xerbla_( + char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical tquery, wquery; + 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 */ + + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tb; + --ipiv; + --ipiv2; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + wquery = *lwork == -1; + tquery = *ltb == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ltb < *n << 2 && ! tquery) { + *info = -6; + } else if (*lwork < *n && ! wquery) { + *info = -10; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRF_AA_2STAGE", &i__1, (ftnlen)16); + return 0; + } + +/* Answer the query */ + + nb = ilaenv_(&c__1, "CSYTRF_AA_2STAGE", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)16, (ftnlen)1); + if (*info == 0) { + if (tquery) { + i__1 = (nb * 3 + 1) * *n; + tb[1].r = (real) i__1, tb[1].i = 0.f; + } + if (wquery) { + i__1 = *n * nb; + work[1].r = (real) i__1, work[1].i = 0.f; + } + } + if (tquery || wquery) { + return 0; + } + +/* Quick return */ + + if (*n == 0) { + return 0; + } + +/* Determine the number of the block size */ + + ldtb = *ltb / *n; + if (ldtb < nb * 3 + 1) { + nb = (ldtb - 1) / 3; + } + if (*lwork < nb * *n) { + nb = *lwork / *n; + } + +/* Determine the number of the block columns */ + + nt = (*n + nb - 1) / nb; + td = nb << 1; + kb = f2cmin(nb,*n); + +/* Initialize vectors/matrices */ + + i__1 = kb; + for (j = 1; j <= i__1; ++j) { + ipiv[j] = j; + } + +/* Save NB */ + + tb[1].r = (real) nb, tb[1].i = 0.f; + + if (upper) { + +/* ..................................................... */ +/* Factorize A as U**T*D*U using the upper triangle of A */ +/* ..................................................... */ + + i__1 = nt - 1; + for (j = 0; j <= i__1; ++j) { + +/* Generate Jth column of W and H */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - j * nb; + kb = f2cmin(i__2,i__3); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (i__ == 1) { +/* H(I,J) = T(I,I)*U(I,J) + T(I+1,I)*U(I+1,J) */ + if (i__ == j - 1) { + jb = nb + kb; + } else { + jb = nb << 1; + } + i__3 = ldtb - 1; + cgemm_("NoTranspose", "NoTranspose", &nb, &kb, &jb, &c_b2, + &tb[td + 1 + i__ * nb * ldtb], &i__3, &a[(i__ - + 1) * nb + 1 + (j * nb + 1) * a_dim1], lda, &c_b1, + &work[i__ * nb + 1], n); + } else { +/* H(I,J) = T(I,I-1)*U(I-1,J) + T(I,I)*U(I,J) + T(I,I+1)*U(I+1,J) */ + if (i__ == j - 1) { + jb = (nb << 1) + kb; + } else { + jb = nb * 3; + } + i__3 = ldtb - 1; + cgemm_("NoTranspose", "NoTranspose", &nb, &kb, &jb, &c_b2, + &tb[td + nb + 1 + (i__ - 1) * nb * ldtb], &i__3, + &a[(i__ - 2) * nb + 1 + (j * nb + 1) * a_dim1], + lda, &c_b1, &work[i__ * nb + 1], n); + } + } + +/* Compute T(J,J) */ + + i__2 = ldtb - 1; + clacpy_("Upper", &kb, &kb, &a[j * nb + 1 + (j * nb + 1) * a_dim1], + lda, &tb[td + 1 + j * nb * ldtb], &i__2); + if (j > 1) { +/* T(J,J) = U(1:J,J)'*H(1:J) */ + i__2 = (j - 1) * nb; + q__1.r = -1.f, q__1.i = 0.f; + i__3 = ldtb - 1; + cgemm_("Transpose", "NoTranspose", &kb, &kb, &i__2, &q__1, &a[ + (j * nb + 1) * a_dim1 + 1], lda, &work[nb + 1], n, & + c_b2, &tb[td + 1 + j * nb * ldtb], &i__3); +/* T(J,J) += U(J,J)'*T(J,J-1)*U(J-1,J) */ + i__2 = ldtb - 1; + cgemm_("Transpose", "NoTranspose", &kb, &nb, &kb, &c_b2, &a[( + j - 1) * nb + 1 + (j * nb + 1) * a_dim1], lda, &tb[td + + nb + 1 + (j - 1) * nb * ldtb], &i__2, &c_b1, &work[ + 1], n); + q__1.r = -1.f, q__1.i = 0.f; + i__2 = ldtb - 1; + cgemm_("NoTranspose", "NoTranspose", &kb, &kb, &nb, &q__1, & + work[1], n, &a[(j - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b2, &tb[td + 1 + j * nb * ldtb], & + i__2); + } + +/* Expand T(J,J) into full format */ + + i__2 = kb; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = kb; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = td + (k - i__) + 1 + (j * nb + i__ - 1) * ldtb; + i__5 = td - (k - (i__ + 1)) + (j * nb + k - 1) * ldtb; + tb[i__4].r = tb[i__5].r, tb[i__4].i = tb[i__5].i; + } + } + if (j > 0) { +/* CALL CHEGST( 1, 'Upper', KB, */ +/* $ TB( TD+1 + (J*NB)*LDTB ), LDTB-1, */ +/* $ A( (J-1)*NB+1, J*NB+1 ), LDA, IINFO ) */ + i__2 = ldtb - 1; + ctrsm_("L", "U", "T", "N", &kb, &kb, &c_b2, &a[(j - 1) * nb + + 1 + (j * nb + 1) * a_dim1], lda, &tb[td + 1 + j * nb * + ldtb], &i__2); + i__2 = ldtb - 1; + ctrsm_("R", "U", "N", "N", &kb, &kb, &c_b2, &a[(j - 1) * nb + + 1 + (j * nb + 1) * a_dim1], lda, &tb[td + 1 + j * nb * + ldtb], &i__2); + } + + if (j < nt - 1) { + if (j > 0) { + +/* Compute H(J,J) */ + + if (j == 1) { + i__2 = ldtb - 1; + cgemm_("NoTranspose", "NoTranspose", &kb, &kb, &kb, & + c_b2, &tb[td + 1 + j * nb * ldtb], &i__2, &a[( + j - 1) * nb + 1 + (j * nb + 1) * a_dim1], lda, + &c_b1, &work[j * nb + 1], n); + } else { + i__2 = nb + kb; + i__3 = ldtb - 1; + cgemm_("NoTranspose", "NoTranspose", &kb, &kb, &i__2, + &c_b2, &tb[td + nb + 1 + (j - 1) * nb * ldtb], + &i__3, &a[(j - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b1, &work[j * nb + 1], n); + } + +/* Update with the previous column */ + + i__2 = *n - (j + 1) * nb; + i__3 = j * nb; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("Transpose", "NoTranspose", &nb, &i__2, &i__3, & + q__1, &work[nb + 1], n, &a[((j + 1) * nb + 1) * + a_dim1 + 1], lda, &c_b2, &a[j * nb + 1 + ((j + 1) + * nb + 1) * a_dim1], lda); + } + +/* Copy panel to workspace to call CGETRF */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = *n - (j + 1) * nb; + ccopy_(&i__3, &a[j * nb + k + ((j + 1) * nb + 1) * a_dim1] + , lda, &work[(k - 1) * *n + 1], &c__1); + } + +/* Factorize panel */ + + i__2 = *n - (j + 1) * nb; + cgetrf_(&i__2, &nb, &work[1], n, &ipiv[(j + 1) * nb + 1], & + iinfo); +/* IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN */ +/* INFO = IINFO+(J+1)*NB */ +/* END IF */ + +/* Copy panel back */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = *n - (j + 1) * nb; + ccopy_(&i__3, &work[(k - 1) * *n + 1], &c__1, &a[j * nb + + k + ((j + 1) * nb + 1) * a_dim1], lda); + } + +/* Compute T(J+1, J), zero out for GEMM update */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - (j + 1) * nb; + kb = f2cmin(i__2,i__3); + i__2 = ldtb - 1; + claset_("Full", &kb, &nb, &c_b1, &c_b1, &tb[td + nb + 1 + j * + nb * ldtb], &i__2); + i__2 = ldtb - 1; + clacpy_("Upper", &kb, &nb, &work[1], n, &tb[td + nb + 1 + j * + nb * ldtb], &i__2); + if (j > 0) { + i__2 = ldtb - 1; + ctrsm_("R", "U", "N", "U", &kb, &nb, &c_b2, &a[(j - 1) * + nb + 1 + (j * nb + 1) * a_dim1], lda, &tb[td + nb + + 1 + j * nb * ldtb], &i__2); + } + +/* Copy T(J,J+1) into T(J+1, J), both upper/lower for GEMM */ +/* updates */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = kb; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = td - nb + k - i__ + 1 + (j * nb + nb + i__ - 1) + * ldtb; + i__5 = td + nb + i__ - k + 1 + (j * nb + k - 1) * + ldtb; + tb[i__4].r = tb[i__5].r, tb[i__4].i = tb[i__5].i; + } + } + claset_("Lower", &kb, &nb, &c_b1, &c_b2, &a[j * nb + 1 + ((j + + 1) * nb + 1) * a_dim1], lda); + +/* Apply pivots to trailing submatrix of A */ + + i__2 = kb; + for (k = 1; k <= i__2; ++k) { +/* > Adjust ipiv */ + ipiv[(j + 1) * nb + k] += (j + 1) * nb; + + i1 = (j + 1) * nb + k; + i2 = ipiv[(j + 1) * nb + k]; + if (i1 != i2) { +/* > Apply pivots to previous columns of L */ + i__3 = k - 1; + cswap_(&i__3, &a[(j + 1) * nb + 1 + i1 * a_dim1], & + c__1, &a[(j + 1) * nb + 1 + i2 * a_dim1], & + c__1); +/* > Swap A(I1+1:M, I1) with A(I2, I1+1:M) */ + if (i2 > i1 + 1) { + i__3 = i2 - i1 - 1; + cswap_(&i__3, &a[i1 + (i1 + 1) * a_dim1], lda, &a[ + i1 + 1 + i2 * a_dim1], &c__1); + } +/* > Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + if (i2 < *n) { + i__3 = *n - i2; + cswap_(&i__3, &a[i1 + (i2 + 1) * a_dim1], lda, &a[ + i2 + (i2 + 1) * a_dim1], lda); + } +/* > Swap A(I1, I1) with A(I2, I2) */ + i__3 = i1 + i1 * a_dim1; + piv.r = a[i__3].r, piv.i = a[i__3].i; + i__3 = i1 + i1 * a_dim1; + i__4 = i2 + i2 * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + i__3 = i2 + i2 * a_dim1; + a[i__3].r = piv.r, a[i__3].i = piv.i; +/* > Apply pivots to previous columns of L */ + if (j > 0) { + i__3 = j * nb; + cswap_(&i__3, &a[i1 * a_dim1 + 1], &c__1, &a[i2 * + a_dim1 + 1], &c__1); + } + } + } + } + } + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T using the lower triangle of A */ +/* ..................................................... */ + + i__1 = nt - 1; + for (j = 0; j <= i__1; ++j) { + +/* Generate Jth column of W and H */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - j * nb; + kb = f2cmin(i__2,i__3); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (i__ == 1) { +/* H(I,J) = T(I,I)*L(J,I)' + T(I+1,I)'*L(J,I+1)' */ + if (i__ == j - 1) { + jb = nb + kb; + } else { + jb = nb << 1; + } + i__3 = ldtb - 1; + cgemm_("NoTranspose", "Transpose", &nb, &kb, &jb, &c_b2, & + tb[td + 1 + i__ * nb * ldtb], &i__3, &a[j * nb + + 1 + ((i__ - 1) * nb + 1) * a_dim1], lda, &c_b1, & + work[i__ * nb + 1], n); + } else { +/* H(I,J) = T(I,I-1)*L(J,I-1)' + T(I,I)*L(J,I)' + T(I,I+1)*L(J,I+1)' */ + if (i__ == j - 1) { + jb = (nb << 1) + kb; + } else { + jb = nb * 3; + } + i__3 = ldtb - 1; + cgemm_("NoTranspose", "Transpose", &nb, &kb, &jb, &c_b2, & + tb[td + nb + 1 + (i__ - 1) * nb * ldtb], &i__3, & + a[j * nb + 1 + ((i__ - 2) * nb + 1) * a_dim1], + lda, &c_b1, &work[i__ * nb + 1], n); + } + } + +/* Compute T(J,J) */ + + i__2 = ldtb - 1; + clacpy_("Lower", &kb, &kb, &a[j * nb + 1 + (j * nb + 1) * a_dim1], + lda, &tb[td + 1 + j * nb * ldtb], &i__2); + if (j > 1) { +/* T(J,J) = L(J,1:J)*H(1:J) */ + i__2 = (j - 1) * nb; + q__1.r = -1.f, q__1.i = 0.f; + i__3 = ldtb - 1; + cgemm_("NoTranspose", "NoTranspose", &kb, &kb, &i__2, &q__1, & + a[j * nb + 1 + a_dim1], lda, &work[nb + 1], n, &c_b2, + &tb[td + 1 + j * nb * ldtb], &i__3); +/* T(J,J) += L(J,J)*T(J,J-1)*L(J,J-1)' */ + i__2 = ldtb - 1; + cgemm_("NoTranspose", "NoTranspose", &kb, &nb, &kb, &c_b2, &a[ + j * nb + 1 + ((j - 1) * nb + 1) * a_dim1], lda, &tb[ + td + nb + 1 + (j - 1) * nb * ldtb], &i__2, &c_b1, & + work[1], n); + q__1.r = -1.f, q__1.i = 0.f; + i__2 = ldtb - 1; + cgemm_("NoTranspose", "Transpose", &kb, &kb, &nb, &q__1, & + work[1], n, &a[j * nb + 1 + ((j - 2) * nb + 1) * + a_dim1], lda, &c_b2, &tb[td + 1 + j * nb * ldtb], & + i__2); + } + +/* Expand T(J,J) into full format */ + + i__2 = kb; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = kb; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = td - (k - (i__ + 1)) + (j * nb + k - 1) * ldtb; + i__5 = td + (k - i__) + 1 + (j * nb + i__ - 1) * ldtb; + tb[i__4].r = tb[i__5].r, tb[i__4].i = tb[i__5].i; + } + } + if (j > 0) { +/* CALL CHEGST( 1, 'Lower', KB, */ +/* $ TB( TD+1 + (J*NB)*LDTB ), LDTB-1, */ +/* $ A( J*NB+1, (J-1)*NB+1 ), LDA, IINFO ) */ + i__2 = ldtb - 1; + ctrsm_("L", "L", "N", "N", &kb, &kb, &c_b2, &a[j * nb + 1 + (( + j - 1) * nb + 1) * a_dim1], lda, &tb[td + 1 + j * nb * + ldtb], &i__2); + i__2 = ldtb - 1; + ctrsm_("R", "L", "T", "N", &kb, &kb, &c_b2, &a[j * nb + 1 + (( + j - 1) * nb + 1) * a_dim1], lda, &tb[td + 1 + j * nb * + ldtb], &i__2); + } + +/* Symmetrize T(J,J) */ + + i__2 = kb; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = kb; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = td - (k - (i__ + 1)) + (j * nb + k - 1) * ldtb; + i__5 = td + (k - i__) + 1 + (j * nb + i__ - 1) * ldtb; + tb[i__4].r = tb[i__5].r, tb[i__4].i = tb[i__5].i; + } + } + + if (j < nt - 1) { + if (j > 0) { + +/* Compute H(J,J) */ + + if (j == 1) { + i__2 = ldtb - 1; + cgemm_("NoTranspose", "Transpose", &kb, &kb, &kb, & + c_b2, &tb[td + 1 + j * nb * ldtb], &i__2, &a[ + j * nb + 1 + ((j - 1) * nb + 1) * a_dim1], + lda, &c_b1, &work[j * nb + 1], n); + } else { + i__2 = nb + kb; + i__3 = ldtb - 1; + cgemm_("NoTranspose", "Transpose", &kb, &kb, &i__2, & + c_b2, &tb[td + nb + 1 + (j - 1) * nb * ldtb], + &i__3, &a[j * nb + 1 + ((j - 2) * nb + 1) * + a_dim1], lda, &c_b1, &work[j * nb + 1], n); + } + +/* Update with the previous column */ + + i__2 = *n - (j + 1) * nb; + i__3 = j * nb; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("NoTranspose", "NoTranspose", &i__2, &nb, &i__3, & + q__1, &a[(j + 1) * nb + 1 + a_dim1], lda, &work[ + nb + 1], n, &c_b2, &a[(j + 1) * nb + 1 + (j * nb + + 1) * a_dim1], lda); + } + +/* Factorize panel */ + + i__2 = *n - (j + 1) * nb; + cgetrf_(&i__2, &nb, &a[(j + 1) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &ipiv[(j + 1) * nb + 1], &iinfo); +/* IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN */ +/* INFO = IINFO+(J+1)*NB */ +/* END IF */ + +/* Compute T(J+1, J), zero out for GEMM update */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - (j + 1) * nb; + kb = f2cmin(i__2,i__3); + i__2 = ldtb - 1; + claset_("Full", &kb, &nb, &c_b1, &c_b1, &tb[td + nb + 1 + j * + nb * ldtb], &i__2); + i__2 = ldtb - 1; + clacpy_("Upper", &kb, &nb, &a[(j + 1) * nb + 1 + (j * nb + 1) + * a_dim1], lda, &tb[td + nb + 1 + j * nb * ldtb], & + i__2); + if (j > 0) { + i__2 = ldtb - 1; + ctrsm_("R", "L", "T", "U", &kb, &nb, &c_b2, &a[j * nb + 1 + + ((j - 1) * nb + 1) * a_dim1], lda, &tb[td + nb + + 1 + j * nb * ldtb], &i__2); + } + +/* Copy T(J+1,J) into T(J, J+1), both upper/lower for GEMM */ +/* updates */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = kb; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = td - nb + k - i__ + 1 + (j * nb + nb + i__ - 1) + * ldtb; + i__5 = td + nb + i__ - k + 1 + (j * nb + k - 1) * + ldtb; + tb[i__4].r = tb[i__5].r, tb[i__4].i = tb[i__5].i; + } + } + claset_("Upper", &kb, &nb, &c_b1, &c_b2, &a[(j + 1) * nb + 1 + + (j * nb + 1) * a_dim1], lda); + +/* Apply pivots to trailing submatrix of A */ + + i__2 = kb; + for (k = 1; k <= i__2; ++k) { +/* > Adjust ipiv */ + ipiv[(j + 1) * nb + k] += (j + 1) * nb; + + i1 = (j + 1) * nb + k; + i2 = ipiv[(j + 1) * nb + k]; + if (i1 != i2) { +/* > Apply pivots to previous columns of L */ + i__3 = k - 1; + cswap_(&i__3, &a[i1 + ((j + 1) * nb + 1) * a_dim1], + lda, &a[i2 + ((j + 1) * nb + 1) * a_dim1], + lda); +/* > Swap A(I1+1:M, I1) with A(I2, I1+1:M) */ + if (i2 > i1 + 1) { + i__3 = i2 - i1 - 1; + cswap_(&i__3, &a[i1 + 1 + i1 * a_dim1], &c__1, &a[ + i2 + (i1 + 1) * a_dim1], lda); + } +/* > Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + if (i2 < *n) { + i__3 = *n - i2; + cswap_(&i__3, &a[i2 + 1 + i1 * a_dim1], &c__1, &a[ + i2 + 1 + i2 * a_dim1], &c__1); + } +/* > Swap A(I1, I1) with A(I2, I2) */ + i__3 = i1 + i1 * a_dim1; + piv.r = a[i__3].r, piv.i = a[i__3].i; + i__3 = i1 + i1 * a_dim1; + i__4 = i2 + i2 * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + i__3 = i2 + i2 * a_dim1; + a[i__3].r = piv.r, a[i__3].i = piv.i; +/* > Apply pivots to previous columns of L */ + if (j > 0) { + i__3 = j * nb; + cswap_(&i__3, &a[i1 + a_dim1], lda, &a[i2 + + a_dim1], lda); + } + } + } + +/* Apply pivots to previous columns of L */ + +/* CALL CLASWP( J*NB, A( 1, 1 ), LDA, */ +/* $ (J+1)*NB+1, (J+1)*NB+KB, IPIV, 1 ) */ + } + } + } + +/* Factor the band matrix */ + cgbtrf_(n, n, &nb, &nb, &tb[1], &ldtb, &ipiv2[1], info); + + return 0; + +/* End of CSYTRF_AA_2STAGE */ + +} /* csytrf_aa_2stage__ */ + diff --git a/lapack-netlib/SRC/csytrf_rk.c b/lapack-netlib/SRC/csytrf_rk.c new file mode 100644 index 000000000..7db91a4a2 --- /dev/null +++ b/lapack-netlib/SRC/csytrf_rk.c @@ -0,0 +1,920 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded + Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRF_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E ( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CSYTRF_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 blocked version of the algorithm, calling Level 3 BLAS. */ +/* > For more information see Further Details section. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > 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] 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. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned */ +/* > by ILAENV. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; */ +/* > the routine only calculates the optimal size of the WORK */ +/* > array, returns this value as the first entry of the WORK */ +/* > array, and no error message related to LWORK is issued */ +/* > by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > < 0: If INFO = -k, the k-th argument had an illegal value */ +/* > */ +/* > > 0: If INFO = k, the matrix A is singular, because: */ +/* > If UPLO = 'U': column k in the upper */ +/* > triangular part of A contains all zeros. */ +/* > If UPLO = 'L': column k in the lower */ +/* > triangular part of A contains all zeros. */ +/* > */ +/* > Therefore D(k,k) is exactly zero, and superdiagonal */ +/* > elements of column k of U (or subdiagonal elements of */ +/* > column k of L ) are all zeros. The factorization has */ +/* > been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if */ +/* > it is used to solve a system of equations. */ +/* > */ +/* > NOTE: INFO only stores the first occurrence of */ +/* > a singularity, any subsequent occurrence of singularity */ +/* > is not stored in INFO even though the factorization */ +/* > always completes. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > TODO: put correct description */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > December 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csytrf_rk_(char *uplo, integer *n, complex *a, integer * + lda, complex *e, integer *ipiv, complex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, k; + extern /* Subroutine */ int csytf2_rk_(char *, integer *, complex *, + integer *, complex *, integer *, integer *); + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *); + logical upper; + extern /* Subroutine */ int clasyf_rk_(char *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, integer *); + integer kb, nb, ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -8; + } + + if (*info == 0) { + +/* Determine the block size */ + + nb = ilaenv_(&c__1, "CSYTRF_RK", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)9, (ftnlen)1); + lwkopt = *n * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRF_RK", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { + iws = ldwork * nb; + if (*lwork < iws) { +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = f2cmax(i__1,1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CSYTRF_RK", uplo, n, &c_n1, & + c_n1, &c_n1, (ftnlen)9, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } else { + iws = 1; + } + if (nb < nbmin) { + nb = *n; + } + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* KB, where KB is the number of columns factorized by CLASYF_RK; */ +/* KB is either NB or NB-1, or K for the last block */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L15; + } + + if (k > nb) { + +/* Factorize columns k-kb+1:k of A and use blocked code to */ +/* update columns 1:k-kb */ + + clasyf_rk_(uplo, &k, &nb, &kb, &a[a_offset], lda, &e[1], &ipiv[1] + , &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + csytf2_rk_(uplo, &k, &a[a_offset], lda, &e[1], &ipiv[1], &iinfo); + kb = k; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + +/* No need to adjust IPIV */ + + +/* Apply permutations to the leading panel 1:k-1 */ + +/* Read IPIV from the last block factored, i.e. */ +/* indices k-kb+1:k and apply row permutations to the */ +/* last k+1 colunms k+1:N after that block */ +/* (We can do the simple loop over IPIV with decrement -1, */ +/* since the ABS value of IPIV( I ) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + if (k < *n) { + i__1 = k - kb + 1; + for (i__ = k; i__ >= i__1; --i__) { + ip = (i__2 = ipiv[i__], abs(i__2)); + if (ip != i__) { + i__2 = *n - k; + cswap_(&i__2, &a[i__ + (k + 1) * a_dim1], lda, &a[ip + (k + + 1) * a_dim1], lda); + } + } + } + +/* Decrease K and return to the start of the main loop */ + + k -= kb; + goto L10; + +/* This label is the exit from main loop over K decreasing */ +/* from N to 1 in steps of KB */ + +L15: + + ; + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* KB, where KB is the number of columns factorized by CLASYF_RK; */ +/* KB is either NB or NB-1, or N-K+1 for the last block */ + + k = 1; +L20: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L35; + } + + if (k <= *n - nb) { + +/* Factorize columns k:k+kb-1 of A and use blocked code to */ +/* update columns k+kb:n */ + + i__1 = *n - k + 1; + clasyf_rk_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &e[k], + &ipiv[k], &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + csytf2_rk_(uplo, &i__1, &a[k + k * a_dim1], lda, &e[k], &ipiv[k], + &iinfo); + kb = *n - k + 1; + + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + k - 1; + } + +/* Adjust IPIV */ + + i__1 = k + kb - 1; + for (i__ = k; i__ <= i__1; ++i__) { + if (ipiv[i__] > 0) { + ipiv[i__] = ipiv[i__] + k - 1; + } else { + ipiv[i__] = ipiv[i__] - k + 1; + } + } + +/* Apply permutations to the leading panel 1:k-1 */ + +/* Read IPIV from the last block factored, i.e. */ +/* indices k:k+kb-1 and apply row permutations to the */ +/* first k-1 colunms 1:k-1 before that block */ +/* (We can do the simple loop over IPIV with increment 1, */ +/* since the ABS value of IPIV( I ) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + if (k > 1) { + i__1 = k + kb - 1; + for (i__ = k; i__ <= i__1; ++i__) { + ip = (i__2 = ipiv[i__], abs(i__2)); + if (ip != i__) { + i__2 = k - 1; + cswap_(&i__2, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda) + ; + } + } + } + +/* Increase K and return to the start of the main loop */ + + k += kb; + goto L20; + +/* This label is the exit from main loop over K increasing */ +/* from 1 to N in steps of KB */ + +L35: + +/* End Lower */ + + ; + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CSYTRF_RK */ + +} /* csytrf_rk__ */ + diff --git a/lapack-netlib/SRC/csytrf_rook.c b/lapack-netlib/SRC/csytrf_rook.c new file mode 100644 index 000000000..58ae0233e --- /dev/null +++ b/lapack-netlib/SRC/csytrf_rook.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 CSYTRF_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRF_ROOK computes the factorization of a complex symmetric matrix A */ +/* > using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. */ +/* > The form of the factorization is */ +/* > */ +/* > A = U*D*U**T or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] 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. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned by ILAENV. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > June 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csytrf_rook_(char *uplo, integer *n, complex *a, + integer *lda, integer *ipiv, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j, k; + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + logical upper; + integer kb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + extern /* Subroutine */ int csytf2_rook_(char *, integer *, complex *, + integer *, integer *, integer *), clasyf_rook_(char *, + integer *, 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..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -7; + } + + if (*info == 0) { + +/* Determine the block size */ + + nb = ilaenv_(&c__1, "CSYTRF_ROOK", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)11, (ftnlen)1); +/* Computing MAX */ + i__1 = 1, i__2 = *n * nb; + lwkopt = f2cmax(i__1,i__2); + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRF_ROOK", &i__1, (ftnlen)11); + return 0; + } else if (lquery) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { + iws = ldwork * nb; + if (*lwork < iws) { +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = f2cmax(i__1,1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CSYTRF_ROOK", uplo, n, &c_n1, & + c_n1, &c_n1, (ftnlen)11, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } else { + iws = 1; + } + if (nb < nbmin) { + nb = *n; + } + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* KB, where KB is the number of columns factorized by CLASYF_ROOK; */ +/* KB is either NB or NB-1, or K for the last block */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L40; + } + + if (k > nb) { + +/* Factorize columns k-kb+1:k of A and use blocked code to */ +/* update columns 1:k-kb */ + + clasyf_rook_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], & + work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + csytf2_rook_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo); + kb = k; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + +/* No need to adjust IPIV */ + +/* Decrease K and return to the start of the main loop */ + + k -= kb; + goto L10; + + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* KB, where KB is the number of columns factorized by CLASYF_ROOK; */ +/* KB is either NB or NB-1, or N-K+1 for the last block */ + + k = 1; +L20: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L40; + } + + if (k <= *n - nb) { + +/* Factorize columns k:k+kb-1 of A and use blocked code to */ +/* update columns k+kb:n */ + + i__1 = *n - k + 1; + clasyf_rook_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, & + ipiv[k], &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + csytf2_rook_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], & + iinfo); + kb = *n - k + 1; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + k - 1; + } + +/* Adjust IPIV */ + + i__1 = k + kb - 1; + for (j = k; j <= i__1; ++j) { + if (ipiv[j] > 0) { + ipiv[j] = ipiv[j] + k - 1; + } else { + ipiv[j] = ipiv[j] - k + 1; + } +/* L30: */ + } + +/* Increase K and return to the start of the main loop */ + + k += kb; + goto L20; + + } + +L40: + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CSYTRF_ROOK */ + +} /* csytrf_rook__ */ + diff --git a/lapack-netlib/SRC/csytri.c b/lapack-netlib/SRC/csytri.c new file mode 100644 index 000000000..177676fea --- /dev/null +++ b/lapack-netlib/SRC/csytri.c @@ -0,0 +1,916 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRI computes the inverse of a complex symmetric indefinite matrix */ +/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* > CSYTRF. */ +/* > \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 block 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] 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] 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, 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 complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytri_(char *uplo, integer *n, complex *a, integer *lda, + integer *ipiv, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + complex q__1, q__2, q__3; + + /* Local variables */ + complex temp, akkp1, d__; + integer 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; + logical upper; + extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex * + , integer *, complex *, integer *, complex *, complex *, integer * + ); + complex ak; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { + return 0; + } +/* 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; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L40; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + (k + 1) * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + c_div(&q__1, &a[k + k * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &a[k + (k + 1) * a_dim1], &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 = k + k * a_dim1; + c_div(&q__1, &akp1, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + 1 + (k + 1) * a_dim1; + c_div(&q__1, &ak, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k + 1) * a_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + a[i__1].r = q__1.r, a[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, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k + 1) * a_dim1; + i__2 = k + (k + 1) * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * + a_dim1 + 1], &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k - 1; + ccopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & + c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1] + , &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 2; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + i__1 = kp - 1; + cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = k - kp - 1; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * + a_dim1], lda); + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + if (kstep == 2) { + i__1 = k + (k + 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k + 1) * a_dim1; + i__2 = kp + (k + 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k + 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + k += kstep; + goto L30; +L40: + + ; + } 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. */ + + k = *n; +L50: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L60; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + (k - 1) * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &a[k + (k - 1) * a_dim1], &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 = k - 1 + (k - 1) * a_dim1; + c_div(&q__1, &akp1, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + k * a_dim1; + c_div(&q__1, &ak, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k - 1) * a_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + a[i__1].r = q__1.r, a[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, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k - 1) * a_dim1; + i__2 = k + (k - 1) * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + + (k - 1) * a_dim1], &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = *n - k; + ccopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & + c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1], + &c__1); + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (k - 1) * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) * + a_dim1], &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 2; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * + a_dim1], &c__1); + } + i__1 = kp - k - 1; + cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + if (kstep == 2) { + i__1 = k + (k - 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k - 1) * a_dim1; + i__2 = kp + (k - 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k - 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + k -= kstep; + goto L50; +L60: + ; + } + + return 0; + +/* End of CSYTRI */ + +} /* csytri_ */ + diff --git a/lapack-netlib/SRC/csytri2.c b/lapack-netlib/SRC/csytri2.c new file mode 100644 index 000000000..e908e3947 --- /dev/null +++ b/lapack-netlib/SRC/csytri2.c @@ -0,0 +1,607 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRI2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRI2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRI2 computes the inverse of a COMPLEX symmetric indefinite matrix */ +/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* > CSYTRF. CSYTRI2 sets the LEADING DIMENSION of the workspace */ +/* > before calling CSYTRI2X that actually computes the inverse. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by 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] 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] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N+NB+1)*(NB+3) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > WORK is size >= (N+NB+1)*(NB+3) */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > calculates: */ +/* > - the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, */ +/* > - and no error message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytri2_(char *uplo, integer *n, complex *a, integer * + lda, integer *ipiv, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int csytri2x_(char *, integer *, complex *, + integer *, integer *, complex *, integer *, integer *); + extern logical lsame_(char *, char *); + integer nbmax; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int csytri_(char *, integer *, complex *, integer + *, integer *, complex *, integer *); + logical lquery; + integer minsize; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; +/* Get blocksize */ + nbmax = ilaenv_(&c__1, "CSYTRI2", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)7, + (ftnlen)1); + if (nbmax >= *n) { + minsize = *n; + } else { + minsize = (*n + nbmax + 1) * (nbmax + 3); + } + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < minsize && ! lquery) { + *info = -7; + } + +/* Quick return if possible */ + + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRI2", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + work[1].r = (real) minsize, work[1].i = 0.f; + return 0; + } + if (*n == 0) { + return 0; + } + if (nbmax >= *n) { + csytri_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], info); + } else { + csytri2x_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &nbmax, + info); + } + return 0; + +/* End of CSYTRI2 */ + +} /* csytri2_ */ + diff --git a/lapack-netlib/SRC/csytri2x.c b/lapack-netlib/SRC/csytri2x.c new file mode 100644 index 000000000..20b73bbe1 --- /dev/null +++ b/lapack-netlib/SRC/csytri2x.c @@ -0,0 +1,1257 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRI2X */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRI2X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( N+NB+1,* ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRI2X computes the inverse of a real symmetric indefinite matrix */ +/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* > CSYTRF. */ +/* > \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 NNB 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] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the NNB structure of D */ +/* > as determined by CSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N+NB+1,NB+3) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > Block size */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytri2x_(char *uplo, integer *n, complex *a, integer * + lda, integer *ipiv, complex *work, integer *nb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, + i__5, i__6; + complex q__1, q__2, q__3; + + /* Local variables */ + integer invd; + complex akkp1; + extern /* Subroutine */ int csyswapr_(char *, integer *, complex *, + integer *, integer *, integer *); + complex d__; + integer i__, j, k; + complex t; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer count; + logical upper; + complex ak, u01_i_j__; + integer u11; + complex u11_i_j__; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), ctrtri_( + char *, char *, integer *, complex *, integer *, integer *); + integer nnb, cut; + complex akp1; + extern /* Subroutine */ int csyconv_(char *, char *, integer *, complex *, + integer *, integer *, complex *, integer *); + complex u01_ip1_j__, u11_ip1_j__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + work_dim1 = *n + *nb + 1; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + +/* Quick return if possible */ + + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRI2X", &i__1, (ftnlen)8); + return 0; + } + if (*n == 0) { + return 0; + } + +/* Convert A */ +/* Workspace got Non-diag elements of D */ + + csyconv_(uplo, "C", n, &a[a_offset], lda, &ipiv[1], &work[work_offset], & + iinfo); + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { + return 0; + } + } + } + *info = 0; + +/* Splitting Workspace */ +/* U01 is a block (N,NB+1) */ +/* The first element of U01 is in WORK(1,1) */ +/* U11 is a block (NB+1,NB+1) */ +/* The first element of U11 is in WORK(N+1,1) */ + u11 = *n; +/* INVD is a block (N,2) */ +/* The first element of INVD is in WORK(1,INVD) */ + invd = *nb + 2; + if (upper) { + +/* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. */ + + ctrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D)*inv(U) */ + + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + i__1 = k + invd * work_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0.f, work[i__1].i = 0.f; + ++k; + } else { +/* 2 x 2 diagonal NNB */ + i__1 = k + 1 + work_dim1; + t.r = work[i__1].r, t.i = work[i__1].i; + c_div(&q__1, &a[k + k * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &work[k + 1 + work_dim1], &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 = k + invd * work_dim1; + c_div(&q__1, &akp1, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + 1 + (invd + 1) * work_dim1; + c_div(&q__1, &ak, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + 1 + invd * work_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + k += 2; + } + } + +/* inv(U**T) = (inv(U))**T */ + +/* inv(U**T)*inv(D)*inv(U) */ + + cut = *n; + while(cut > 0) { + nnb = *nb; + if (cut <= nnb) { + nnb = cut; + } else { + count = 0; +/* count negative elements, */ + i__1 = cut; + for (i__ = cut + 1 - nnb; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++count; + } + } +/* need a even number for a clear cut */ + if (count % 2 == 1) { + ++nnb; + } + } + cut -= nnb; + +/* U01 Block */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* U11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1.f, work[i__2].i = 0.f; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0.f, work[i__3].i = 0.f; + } + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* invD*U01 */ + + i__ = 1; + while(i__ <= cut) { + if (ipiv[i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + ++i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ + 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = i__ + 1 + j * work_dim1; + i__3 = i__ + 1 + invd * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + 1 + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + i__ += 2; + } + } + +/* invD1*U11 */ + + i__ = 1; + while(i__ <= nnb) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + ++i__; + } else { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ + 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + i__6 = u11 + i__ + 1 + j * work_dim1; + q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * + work[i__6].i, q__3.i = work[i__5].r * work[ + i__6].i + work[i__5].i * work[i__6].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = u11 + i__ + 1 + j * work_dim1; + i__3 = cut + i__ + 1 + invd * work_dim1; + q__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, q__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ + 1 + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, q__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + i__ += 2; + } + } + +/* U11**T*invD1*U11->U11 */ + + i__1 = *n + *nb + 1; + ctrmm_("L", "U", "T", "U", &nnb, &nnb, &c_b1, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* U01**T*invD*U01->A(CUT+I,CUT+J) */ + + i__1 = *n + *nb + 1; + i__2 = *n + *nb + 1; + cgemm_("T", "N", &nnb, &nnb, &cut, &c_b1, &a[(cut + 1) * a_dim1 + + 1], lda, &work[work_offset], &i__1, &c_b2, &work[u11 + 1 + + work_dim1], &i__2); + +/* U11 = U11**T*invD1*U11 + U01**T*invD*U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + q__1.r = a[i__4].r + work[i__5].r, q__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + +/* U01 = U00**T*invD0*U01 */ + + i__1 = *n + *nb + 1; + ctrmm_("L", uplo, "T", "U", &cut, &nnb, &c_b1, &a[a_offset], lda, + &work[work_offset], &i__1); + +/* Update U01 */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* Next Block */ + + } + +/* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } else { + ip = -ipiv[i__]; + ++i__; + if (i__ - 1 < ip) { + i__1 = i__ - 1; + csyswapr_(uplo, n, &a[a_offset], lda, &i__1, &ip); + } + if (i__ - 1 > ip) { + i__1 = i__ - 1; + csyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__1); + } + } + ++i__; + } + } else { + +/* LOWER... */ + +/* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. */ + + ctrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D)*inv(U) */ + + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + i__1 = k + invd * work_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0.f, work[i__1].i = 0.f; + --k; + } else { +/* 2 x 2 diagonal NNB */ + i__1 = k - 1 + work_dim1; + t.r = work[i__1].r, t.i = work[i__1].i; + c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &work[k - 1 + work_dim1], &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 = k - 1 + invd * work_dim1; + c_div(&q__1, &akp1, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + invd * work_dim1; + c_div(&q__1, &ak, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k - 1 + (invd + 1) * work_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + k += -2; + } + } + +/* inv(U**T) = (inv(U))**T */ + +/* inv(U**T)*inv(D)*inv(U) */ + + cut = 0; + while(cut < *n) { + nnb = *nb; + if (cut + nnb >= *n) { + nnb = *n - cut; + } else { + count = 0; +/* count negative elements, */ + i__1 = cut + nnb; + for (i__ = cut + 1; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++count; + } + } +/* need a even number for a clear cut */ + if (count % 2 == 1) { + ++nnb; + } + } +/* L21 Block */ + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * work_dim1; + i__4 = cut + nnb + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } +/* L11 Block */ + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1.f, work[i__2].i = 0.f; + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0.f, work[i__3].i = 0.f; + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* invD*L21 */ + + i__ = *n - cut - nnb; + while(i__ >= 1) { + if (ipiv[cut + nnb + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + --i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ - 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = i__ - 1 + j * work_dim1; + i__3 = cut + nnb + i__ - 1 + (invd + 1) * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ - 1 + invd * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + i__ += -2; + } + } + +/* invD1*L11 */ + + i__ = nnb; + while(i__ >= 1) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + --i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ - 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + q__3.r = work[i__5].r * u11_ip1_j__.r - work[i__5].i * + u11_ip1_j__.i, q__3.i = work[i__5].r * + u11_ip1_j__.i + work[i__5].i * u11_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = u11 + i__ - 1 + j * work_dim1; + i__3 = cut + i__ - 1 + (invd + 1) * work_dim1; + q__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, q__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ - 1 + invd * work_dim1; + q__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, q__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + i__ += -2; + } + } + +/* L11**T*invD1*L11->L11 */ + + i__1 = *n + *nb + 1; + ctrmm_("L", uplo, "T", "U", &nnb, &nnb, &c_b1, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + + if (cut + nnb < *n) { + +/* L21**T*invD2*L21->A(CUT+I,CUT+J) */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + i__3 = *n + *nb + 1; + cgemm_("T", "N", &nnb, &nnb, &i__1, &c_b1, &a[cut + nnb + 1 + + (cut + 1) * a_dim1], lda, &work[work_offset], &i__2, & + c_b2, &work[u11 + 1 + work_dim1], &i__3); + +/* L11 = L11**T*invD1*L11 + U01**T*invD*U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + q__1.r = a[i__4].r + work[i__5].r, q__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + +/* L01 = L22**T*invD2*L21 */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + ctrmm_("L", uplo, "T", "U", &i__1, &nnb, &c_b1, &a[cut + nnb + + 1 + (cut + nnb + 1) * a_dim1], lda, &work[ + work_offset], &i__2); +/* Update L21 */ + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + nnb + i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + } else { + +/* L11 = L11**T*invD1*L11 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + } + +/* Next Block */ + + cut += nnb; + } + +/* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } else { + ip = -ipiv[i__]; + if (i__ < ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + --i__; + } + --i__; + } + } + + return 0; + +/* End of CSYTRI2X */ + +} /* csytri2x_ */ + diff --git a/lapack-netlib/SRC/csytri_3.c b/lapack-netlib/SRC/csytri_3.c new file mode 100644 index 000000000..027e3eef2 --- /dev/null +++ b/lapack-netlib/SRC/csytri_3.c @@ -0,0 +1,649 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRI_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRI_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CSYTRI_3 computes the inverse of a complex symmetric indefinite */ +/* > 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. */ +/* > */ +/* > CSYTRI_3 sets the leading dimension of the workspace before calling */ +/* > CSYTRI_3X that actually computes the inverse. This is the blocked */ +/* > version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, 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. */ +/* > */ +/* > 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] 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[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N+NB+1)*(NB+3). */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= (N+NB+1)*(NB+3). */ +/* > */ +/* > If LDWORK = -1, then a workspace query is assumed; */ +/* > the routine only calculates the optimal size of the optimal */ +/* > size of the WORK array, returns this value as the first */ +/* > entry of the WORK array, and no error message related to */ +/* > LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > November 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csytri_3_(char *uplo, integer *n, complex *a, integer * + lda, complex *e, integer *ipiv, complex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int csytri_3x_(char *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *, integer *); + logical upper; + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + +/* Determine the block size */ + +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "CSYTRI_3", uplo, n, &c_n1, &c_n1, &c_n1, + (ftnlen)8, (ftnlen)1); + nb = f2cmax(i__1,i__2); + lwkopt = (*n + nb + 1) * (nb + 3); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < lwkopt && ! lquery) { + *info = -8; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRI_3", &i__1, (ftnlen)8); + return 0; + } else if (lquery) { + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + csytri_3x_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], &nb, + info); + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CSYTRI_3 */ + +} /* csytri_3__ */ + diff --git a/lapack-netlib/SRC/csytri_3x.c b/lapack-netlib/SRC/csytri_3x.c new file mode 100644 index 000000000..1262ecc56 --- /dev/null +++ b/lapack-netlib/SRC/csytri_3x.c @@ -0,0 +1,1306 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRI_3X */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRI_3X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CSYTRI_3X computes the inverse of a complex symmetric indefinite */ +/* > 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. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, 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. */ +/* > */ +/* > 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] 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[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N+NB+1,NB+3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > Block size. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > June 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int csytri_3x_(char *uplo, integer *n, complex *a, integer * + lda, complex *e, integer *ipiv, complex *work, integer *nb, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, + i__5, i__6; + complex q__1, q__2, q__3; + + /* Local variables */ + integer invd; + complex akkp1; + extern /* Subroutine */ int csyswapr_(char *, integer *, complex *, + integer *, integer *, integer *); + complex d__; + integer i__, j, k; + complex t; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + complex ak, u01_i_j__; + integer u11; + complex u11_i_j__; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer icount; + extern /* Subroutine */ int ctrtri_(char *, char *, integer *, complex *, + integer *, integer *); + integer nnb, cut; + complex akp1, u01_ip1_j__, u11_ip1_j__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + work_dim1 = *n + *nb + 1; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + +/* Quick return if possible */ + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRI_3X", &i__1, (ftnlen)9); + return 0; + } + if (*n == 0) { + return 0; + } + +/* Workspace got Non-diag elements of D */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k + work_dim1; + i__3 = k; + work[i__2].r = e[i__3].r, work[i__2].i = e[i__3].i; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { + return 0; + } + } + } + + *info = 0; + +/* Splitting Workspace */ +/* U01 is a block ( N, NB+1 ) */ +/* The first element of U01 is in WORK( 1, 1 ) */ +/* U11 is a block ( NB+1, NB+1 ) */ +/* The first element of U11 is in WORK( N+1, 1 ) */ + + u11 = *n; + +/* INVD is a block ( N, 2 ) */ +/* The first element of INVD is in WORK( 1, INVD ) */ + + invd = *nb + 2; + if (upper) { + +/* Begin Upper */ + +/* invA = P * inv(U**T) * inv(D) * inv(U) * P**T. */ + + ctrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D) * inv(U) */ + + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + i__1 = k + invd * work_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0.f, work[i__1].i = 0.f; + } else { +/* 2 x 2 diagonal NNB */ + i__1 = k + 1 + work_dim1; + t.r = work[i__1].r, t.i = work[i__1].i; + c_div(&q__1, &a[k + k * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &work[k + 1 + work_dim1], &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 = k + invd * work_dim1; + c_div(&q__1, &akp1, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + 1 + (invd + 1) * work_dim1; + c_div(&q__1, &ak, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + 1 + invd * work_dim1; + i__2 = k + (invd + 1) * work_dim1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + ++k; + } + ++k; + } + +/* inv(U**T) = (inv(U))**T */ + +/* inv(U**T) * inv(D) * inv(U) */ + + cut = *n; + while(cut > 0) { + nnb = *nb; + if (cut <= nnb) { + nnb = cut; + } else { + icount = 0; +/* count negative elements, */ + i__1 = cut; + for (i__ = cut + 1 - nnb; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++icount; + } + } +/* need a even number for a clear cut */ + if (icount % 2 == 1) { + ++nnb; + } + } + cut -= nnb; + +/* U01 Block */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* U11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1.f, work[i__2].i = 0.f; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0.f, work[i__3].i = 0.f; + } + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* invD * U01 */ + + i__ = 1; + while(i__ <= cut) { + if (ipiv[i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ + 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = i__ + 1 + j * work_dim1; + i__3 = i__ + 1 + invd * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + 1 + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + ++i__; + } + ++i__; + } + +/* invD1 * U11 */ + + i__ = 1; + while(i__ <= nnb) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + } else { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ + 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + i__6 = u11 + i__ + 1 + j * work_dim1; + q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * + work[i__6].i, q__3.i = work[i__5].r * work[ + i__6].i + work[i__5].i * work[i__6].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = u11 + i__ + 1 + j * work_dim1; + i__3 = cut + i__ + 1 + invd * work_dim1; + q__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, q__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ + 1 + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, q__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + ++i__; + } + ++i__; + } + +/* U11**T * invD1 * U11 -> U11 */ + + i__1 = *n + *nb + 1; + ctrmm_("L", "U", "T", "U", &nnb, &nnb, &c_b1, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* U01**T * invD * U01 -> A( CUT+I, CUT+J ) */ + + i__1 = *n + *nb + 1; + i__2 = *n + *nb + 1; + cgemm_("T", "N", &nnb, &nnb, &cut, &c_b1, &a[(cut + 1) * a_dim1 + + 1], lda, &work[work_offset], &i__1, &c_b2, &work[u11 + 1 + + work_dim1], &i__2); + +/* U11 = U11**T * invD1 * U11 + U01**T * invD * U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + q__1.r = a[i__4].r + work[i__5].r, q__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + +/* U01 = U00**T * invD0 * U01 */ + + i__1 = *n + *nb + 1; + ctrmm_("L", uplo, "T", "U", &cut, &nnb, &c_b1, &a[a_offset], lda, + &work[work_offset], &i__1); + +/* Update U01 */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* Next Block */ + + } + +/* Apply PERMUTATIONS P and P**T: */ +/* P * inv(U**T) * inv(D) * inv(U) * P**T. */ +/* Interchange rows and columns I and IPIV(I) in reverse order */ +/* from the formation order of IPIV vector for Upper case. */ + +/* ( We can use a loop over IPIV with increment 1, */ +/* since the ABS value of IPIV(I) represents the row (column) */ +/* index of the interchange with row (column) i in both 1x1 */ +/* and 2x2 pivot cases, i.e. we don't need separate code branches */ +/* for 1x1 and 2x2 pivot cases ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ip = (i__2 = ipiv[i__], abs(i__2)); + if (ip != i__) { + if (i__ < ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } + } + + } else { + +/* Begin Lower */ + +/* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T. */ + + ctrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D) * inv(L) */ + + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + i__1 = k + invd * work_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0.f, work[i__1].i = 0.f; + } else { +/* 2 x 2 diagonal NNB */ + i__1 = k - 1 + work_dim1; + t.r = work[i__1].r, t.i = work[i__1].i; + c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &work[k - 1 + work_dim1], &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 = k - 1 + invd * work_dim1; + c_div(&q__1, &akp1, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + invd * work_dim1; + c_div(&q__1, &ak, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k + (invd + 1) * work_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = k - 1 + (invd + 1) * work_dim1; + i__2 = k + (invd + 1) * work_dim1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + --k; + } + --k; + } + +/* inv(L**T) = (inv(L))**T */ + +/* inv(L**T) * inv(D) * inv(L) */ + + cut = 0; + while(cut < *n) { + nnb = *nb; + if (cut + nnb > *n) { + nnb = *n - cut; + } else { + icount = 0; +/* count negative elements, */ + i__1 = cut + nnb; + for (i__ = cut + 1; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++icount; + } + } +/* need a even number for a clear cut */ + if (icount % 2 == 1) { + ++nnb; + } + } + +/* L21 Block */ + + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * work_dim1; + i__4 = cut + nnb + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* L11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1.f, work[i__2].i = 0.f; + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0.f, work[i__3].i = 0.f; + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* invD*L21 */ + + i__ = *n - cut - nnb; + while(i__ >= 1) { + if (ipiv[cut + nnb + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ - 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ + (invd + 1) * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = i__ - 1 + j * work_dim1; + i__3 = cut + nnb + i__ - 1 + (invd + 1) * work_dim1; + q__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, q__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ - 1 + invd * work_dim1; + q__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, q__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + --i__; + } + --i__; + } + +/* invD1*L11 */ + + i__ = nnb; + while(i__ >= 1) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ - 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + q__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, q__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + q__3.r = work[i__5].r * u11_ip1_j__.r - work[i__5].i * + u11_ip1_j__.i, q__3.i = work[i__5].r * + u11_ip1_j__.i + work[i__5].i * u11_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = u11 + i__ - 1 + j * work_dim1; + i__3 = cut + i__ - 1 + (invd + 1) * work_dim1; + q__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, q__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ - 1 + invd * work_dim1; + q__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, q__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + } + --i__; + } + --i__; + } + +/* L11**T * invD1 * L11 -> L11 */ + + i__1 = *n + *nb + 1; + ctrmm_("L", uplo, "T", "U", &nnb, &nnb, &c_b1, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + + if (cut + nnb < *n) { + +/* L21**T * invD2*L21 -> A( CUT+I, CUT+J ) */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + i__3 = *n + *nb + 1; + cgemm_("T", "N", &nnb, &nnb, &i__1, &c_b1, &a[cut + nnb + 1 + + (cut + 1) * a_dim1], lda, &work[work_offset], &i__2, & + c_b2, &work[u11 + 1 + work_dim1], &i__3); + +/* L11 = L11**T * invD1 * L11 + U01**T * invD * U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + q__1.r = a[i__4].r + work[i__5].r, q__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + +/* L01 = L22**T * invD2 * L21 */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + ctrmm_("L", uplo, "T", "U", &i__1, &nnb, &c_b1, &a[cut + nnb + + 1 + (cut + nnb + 1) * a_dim1], lda, &work[ + work_offset], &i__2); + +/* Update L21 */ + + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + nnb + i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + + } else { + +/* L11 = L11**T * invD1 * L11 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + } + +/* Next Block */ + + cut += nnb; + + } + +/* Apply PERMUTATIONS P and P**T: */ +/* P * inv(L**T) * inv(D) * inv(L) * P**T. */ +/* Interchange rows and columns I and IPIV(I) in reverse order */ +/* from the formation order of IPIV vector for Lower case. */ + +/* ( We can use a loop over IPIV with increment -1, */ +/* since the ABS value of IPIV(I) represents the row (column) */ +/* index of the interchange with row (column) i in both 1x1 */ +/* and 2x2 pivot cases, i.e. we don't need separate code branches */ +/* for 1x1 and 2x2 pivot cases ) */ + + for (i__ = *n; i__ >= 1; --i__) { + ip = (i__1 = ipiv[i__], abs(i__1)); + if (ip != i__) { + if (i__ < ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + csyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } + } + + } + + return 0; + +/* End of CSYTRI_3X */ + +} /* csytri_3x__ */ + diff --git a/lapack-netlib/SRC/csytri_rook.c b/lapack-netlib/SRC/csytri_rook.c new file mode 100644 index 000000000..ea4b11ac6 --- /dev/null +++ b/lapack-netlib/SRC/csytri_rook.c @@ -0,0 +1,1021 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRI_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRI_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRI_ROOK computes the inverse of a complex symmetric */ +/* > matrix A using the factorization A = U*D*U**T or A = L*D*L**T */ +/* > computed by CSYTRF_ROOK. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**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 block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by CSYTRF_ROOK. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix. If UPLO = 'U', the upper triangular part of the */ +/* > inverse is formed and the part of A below the diagonal is not */ +/* > referenced; if UPLO = 'L' the lower triangular part of the */ +/* > inverse is formed and the part of A above the diagonal is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CSYTRF_ROOK. */ +/* > \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 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 csytri_rook_(char *uplo, integer *n, complex *a, + integer *lda, integer *ipiv, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + complex q__1, q__2, q__3; + + /* Local variables */ + complex temp, akkp1, d__; + integer 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; + logical upper; + extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex * + , integer *, complex *, integer *, complex *, complex *, integer * + ); + complex ak; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRI_ROOK", &i__1, (ftnlen)11); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { + return 0; + } +/* 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; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L40; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + (k + 1) * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + c_div(&q__1, &a[k + k * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &a[k + (k + 1) * a_dim1], &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 = k + k * a_dim1; + c_div(&q__1, &akp1, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + 1 + (k + 1) * a_dim1; + c_div(&q__1, &ak, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k + 1) * a_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + a[i__1].r = q__1.r, a[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, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k + 1) * a_dim1; + i__2 = k + (k + 1) * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * + a_dim1 + 1], &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k - 1; + ccopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & + c__1); + i__1 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * a_dim1; + i__3 = k - 1; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1] + , &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 2; + } + + if (kstep == 1) { + +/* Interchange rows and columns K and IPIV(K) in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + kp = ipiv[k]; + if (kp != k) { + if (kp > 1) { + i__1 = kp - 1; + cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + i__1 = k - kp - 1; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) + * a_dim1], lda); + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } else { + +/* Interchange rows and columns K and K+1 with -IPIV(K) and */ +/* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) */ + + kp = -ipiv[k]; + if (kp != k) { + if (kp > 1) { + i__1 = kp - 1; + cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + i__1 = k - kp - 1; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) + * a_dim1], lda); + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + i__1 = k + (k + 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k + 1) * a_dim1; + i__2 = kp + (k + 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k + 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + + ++k; + kp = -ipiv[k]; + if (kp != k) { + if (kp > 1) { + i__1 = kp - 1; + cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + i__1 = k - kp - 1; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) + * a_dim1], lda); + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + ++k; + goto L30; +L40: + + ; + } 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. */ + + k = *n; +L50: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L60; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + (k - 1) * a_dim1; + t.r = a[i__1].r, t.i = a[i__1].i; + c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &t); + ak.r = q__1.r, ak.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &t); + akp1.r = q__1.r, akp1.i = q__1.i; + c_div(&q__1, &a[k + (k - 1) * a_dim1], &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 = k - 1 + (k - 1) * a_dim1; + c_div(&q__1, &akp1, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + k * a_dim1; + c_div(&q__1, &ak, &d__); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k - 1) * a_dim1; + q__2.r = -akkp1.r, q__2.i = -akkp1.i; + c_div(&q__1, &q__2, &d__); + a[i__1].r = q__1.r, a[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, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = k + (k - 1) * a_dim1; + i__2 = k + (k - 1) * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + + (k - 1) * a_dim1], &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = *n - k; + ccopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & + c__1); + i__1 = *n - k; + q__1.r = -1.f, q__1.i = 0.f; + csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1], + &c__1); + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (k - 1) * a_dim1; + i__3 = *n - k; + cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) * + a_dim1], &c__1); + q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + kstep = 2; + } + + if (kstep == 1) { + +/* Interchange rows and columns K and IPIV(K) in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + kp = ipiv[k]; + if (kp != k) { + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - k - 1; + cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } else { + +/* Interchange rows and columns K and K-1 with -IPIV(K) and */ +/* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) */ + + kp = -ipiv[k]; + if (kp != k) { + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - k - 1; + cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + i__1 = k + (k - 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k - 1) * a_dim1; + i__2 = kp + (k - 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k - 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + + --k; + kp = -ipiv[k]; + if (kp != k) { + if (kp < *n) { + i__1 = *n - kp; + cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - k - 1; + cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + --k; + goto L50; +L60: + ; + } + + return 0; + +/* End of CSYTRI_ROOK */ + +} /* csytri_rook__ */ + diff --git a/lapack-netlib/SRC/csytrs.c b/lapack-netlib/SRC/csytrs.c new file mode 100644 index 000000000..dd104fde6 --- /dev/null +++ b/lapack-netlib/SRC/csytrs.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 CSYTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRS solves a system of linear equations A*X = B with a complex */ +/* > symmetric matrix A using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by CSYTRF. */ +/* > \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] 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,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 complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex * + a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, 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 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRS", &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; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + 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, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + 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, &a[k * a_dim1 + 1], &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, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k + - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = k - 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &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: */ + } + 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; +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, &a[k * + a_dim1 + 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(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, &a[k * + a_dim1 + 1], &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, &a[(k + + 1) * a_dim1 + 1], &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); + } + 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; +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, &a[k + 1 + k * a_dim1], &c__1, &b[ + k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + 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(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, &a[k + 2 + k * a_dim1], &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, &a[k + 2 + (k + 1) * a_dim1], & + c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], + ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = k + 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + c_div(&q__1, &a[k + k * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &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: */ + } + 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; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L**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, &a[k + 1 + k * a_dim1], &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, &a[k + 1 + k * a_dim1], &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, &a[k + 1 + (k - 1) * a_dim1], &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); + } + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of CSYTRS */ + +} /* csytrs_ */ + diff --git a/lapack-netlib/SRC/csytrs2.c b/lapack-netlib/SRC/csytrs2.c new file mode 100644 index 000000000..e48050df7 --- /dev/null +++ b/lapack-netlib/SRC/csytrs2.c @@ -0,0 +1,820 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRS2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, */ +/* WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRS2 solves a system of linear equations A*X = B with a complex */ +/* > symmetric matrix A using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by CSYTRF and converted by CSYCONV. */ +/* > \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,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. */ +/* > Note that A is input / output. This might be counter-intuitive, */ +/* > and one may think that A is input only. A is input / output. This */ +/* > is because, at the start of the subroutine, we permute A in a */ +/* > "better" form and then we permute A back to its original form at */ +/* > the end. */ +/* > \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,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 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 complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytrs2_(char *uplo, integer *n, integer *nrhs, complex * + a, integer *lda, integer *ipiv, complex *b, integer *ldb, complex * + work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + complex q__1, q__2, q__3; + + /* Local variables */ + complex akm1k; + integer i__, j, k; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + complex denom; + integer iinfo; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *), ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + complex ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + complex akm1, bkm1; + extern /* Subroutine */ int csyconv_(char *, char *, integer *, complex *, + integer *, 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRS2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Convert A */ + + csyconv_(uplo, "C", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo); + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* P**T * B */ + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K-1 and -IPIV(K). */ + kp = -ipiv[k]; + if (kp == -ipiv[k - 1]) { + cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], + ldb); + } + k += -2; + } + } + +/* Compute (U \P**T * B) -> B [ (U \P**T * B) ] */ + + ctrsm_("L", "U", "N", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (U \P**T * B) ] */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + c_div(&q__1, &c_b1, &a[i__ + i__ * a_dim1]); + cscal_(nrhs, &q__1, &b[i__ + b_dim1], ldb); + } else if (i__ > 1) { + if (ipiv[i__ - 1] == ipiv[i__]) { + i__1 = i__; + akm1k.r = work[i__1].r, akm1k.i = work[i__1].i; + c_div(&q__1, &a[i__ - 1 + (i__ - 1) * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[i__ + i__ * a_dim1], &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[i__ - 1 + j * b_dim1], &akm1k); + bkm1.r = q__1.r, bkm1.i = q__1.i; + c_div(&q__1, &b[i__ + j * b_dim1], &akm1k); + bk.r = q__1.r, bk.i = q__1.i; + i__2 = i__ - 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 = i__ + 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; +/* L15: */ + } + --i__; + } + } + --i__; + } + +/* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] */ + + ctrsm_("L", "U", "T", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] */ + + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K-1 and -IPIV(K). */ + kp = -ipiv[k]; + if (k < *n && kp == -ipiv[k + 1]) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += 2; + } + } + + } else { + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* P**T * B */ + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K and -IPIV(K+1). */ + kp = -ipiv[k + 1]; + if (kp == -ipiv[k]) { + cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], + ldb); + } + k += 2; + } + } + +/* Compute (L \P**T * B) -> B [ (L \P**T * B) ] */ + + ctrsm_("L", "L", "N", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (L \P**T * B) ] */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + c_div(&q__1, &c_b1, &a[i__ + i__ * a_dim1]); + cscal_(nrhs, &q__1, &b[i__ + b_dim1], ldb); + } else { + i__1 = i__; + akm1k.r = work[i__1].r, akm1k.i = work[i__1].i; + c_div(&q__1, &a[i__ + i__ * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[i__ + 1 + (i__ + 1) * a_dim1], &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[i__ + j * b_dim1], &akm1k); + bkm1.r = q__1.r, bkm1.i = q__1.i; + c_div(&q__1, &b[i__ + 1 + j * b_dim1], &akm1k); + bk.r = q__1.r, bk.i = q__1.i; + i__2 = i__ + 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 = i__ + 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; +/* L25: */ + } + ++i__; + } + ++i__; + } + +/* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] */ + + ctrsm_("L", "L", "T", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] */ + + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K-1 and -IPIV(K). */ + kp = -ipiv[k]; + if (k > 1 && kp == -ipiv[k - 1]) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += -2; + } + } + + } + +/* Revert A */ + + csyconv_(uplo, "R", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo); + + return 0; + +/* End of CSYTRS2 */ + +} /* csytrs2_ */ + diff --git a/lapack-netlib/SRC/csytrs_3.c b/lapack-netlib/SRC/csytrs_3.c new file mode 100644 index 000000000..d9a31bf34 --- /dev/null +++ b/lapack-netlib/SRC/csytrs_3.c @@ -0,0 +1,817 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRS_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRS_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > CSYTRS_3 solves a system of linear equations A * X = B with 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. */ +/* > */ +/* > This algorithm is using Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix: */ +/* > = 'U': Upper triangular, form is A = P*U*D*(U**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] 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) */ +/* > 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,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 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 csytrs_3_(char *uplo, integer *n, integer *nrhs, + complex *a, integer *lda, complex *e, integer *ipiv, complex *b, + integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + complex q__1, q__2, q__3; + + /* Local variables */ + complex akm1k; + integer i__, j, k; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + complex denom; + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *), ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + complex ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + complex akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRS_3", &i__1, (ftnlen)8); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Begin Upper */ + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* P**T * B */ + +/* Interchange rows K and IPIV(K) of matrix B in the same order */ +/* that the formation order of IPIV(I) vector for Upper case. */ + +/* (We can do the simple loop over IPIV with decrement -1, */ +/* since the ABS value of IPIV(I) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + for (k = *n; k >= 1; --k) { + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute (U \P**T * B) -> B [ (U \P**T * B) ] */ + + ctrsm_("L", "U", "N", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (U \P**T * B) ] */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + c_div(&q__1, &c_b1, &a[i__ + i__ * a_dim1]); + cscal_(nrhs, &q__1, &b[i__ + b_dim1], ldb); + } else if (i__ > 1) { + i__1 = i__; + akm1k.r = e[i__1].r, akm1k.i = e[i__1].i; + c_div(&q__1, &a[i__ - 1 + (i__ - 1) * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[i__ + i__ * a_dim1], &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[i__ - 1 + j * b_dim1], &akm1k); + bkm1.r = q__1.r, bkm1.i = q__1.i; + c_div(&q__1, &b[i__ + j * b_dim1], &akm1k); + bk.r = q__1.r, bk.i = q__1.i; + i__2 = i__ - 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 = i__ + 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; + } + --i__; + } + --i__; + } + +/* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] */ + + ctrsm_("L", "U", "T", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] */ + +/* Interchange rows K and IPIV(K) of matrix B in reverse order */ +/* from the formation order of IPIV(I) vector for Upper case. */ + +/* (We can do the simple loop over IPIV with increment 1, */ +/* since the ABS value of IPIV( I ) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = (i__2 = ipiv[k], abs(i__2)); + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + + } else { + +/* Begin Lower */ + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* P**T * B */ +/* Interchange rows K and IPIV(K) of matrix B in the same order */ +/* that the formation order of IPIV(I) vector for Lower case. */ + +/* (We can do the simple loop over IPIV with increment 1, */ +/* since the ABS value of IPIV(I) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = (i__2 = ipiv[k], abs(i__2)); + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute (L \P**T * B) -> B [ (L \P**T * B) ] */ + + ctrsm_("L", "L", "N", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (L \P**T * B) ] */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + c_div(&q__1, &c_b1, &a[i__ + i__ * a_dim1]); + cscal_(nrhs, &q__1, &b[i__ + b_dim1], ldb); + } else if (i__ < *n) { + i__1 = i__; + akm1k.r = e[i__1].r, akm1k.i = e[i__1].i; + c_div(&q__1, &a[i__ + i__ * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[i__ + 1 + (i__ + 1) * a_dim1], &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[i__ + j * b_dim1], &akm1k); + bkm1.r = q__1.r, bkm1.i = q__1.i; + c_div(&q__1, &b[i__ + 1 + j * b_dim1], &akm1k); + bk.r = q__1.r, bk.i = q__1.i; + i__2 = i__ + 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 = i__ + 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; + } + ++i__; + } + ++i__; + } + +/* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] */ + + ctrsm_("L", "L", "T", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] */ + +/* Interchange rows K and IPIV(K) of matrix B in reverse order */ +/* from the formation order of IPIV(I) vector for Lower case. */ + +/* (We can do the simple loop over IPIV with decrement -1, */ +/* since the ABS value of IPIV(I) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + for (k = *n; k >= 1; --k) { + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* END Lower */ + + } + + return 0; + +/* End of CSYTRS_3 */ + +} /* csytrs_3__ */ + diff --git a/lapack-netlib/SRC/csytrs_aa.c b/lapack-netlib/SRC/csytrs_aa.c new file mode 100644 index 000000000..68eedac6f --- /dev/null +++ b/lapack-netlib/SRC/csytrs_aa.c @@ -0,0 +1,739 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRS_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRS_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRS_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 */ +/* > */ +/* > CSYTRS_AA solves a system of linear equations A*X = B with a complex */ +/* > symmetric matrix A using the factorization A = U**T*T*U or */ +/* > A = L*T*L**T computed by CSYTRF_AA. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U**T*T*U; */ +/* > = 'L': Lower triangular, form is A = L*T*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] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > Details of factors computed by CSYTRF_AA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges as computed by CSYTRF_AA. */ +/* > \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 array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,3*N-2). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytrs_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 */ + integer k; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cswap_(integer *, complex *, integer *, + complex *, integer *), cgtsv_(integer *, integer *, complex *, + complex *, complex *, complex *, integer *, integer *), ctrsm_( + char *, char *, char *, char *, integer *, integer *, complex *, + complex *, integer *, complex *, integer *); + logical upper; + integer kp; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3 - 2; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -10; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRS_AA", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + lwkopt = *n * 3 - 2; + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U**T*T*U. */ + +/* 1) Forward substitution with U**T */ + + if (*n > 1) { + +/* Pivot, P**T * B -> B */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute U**T \ B -> B [ (U**T \P**T * B) ] */ + + i__1 = *n - 1; + ctrsm_("L", "U", "T", "U", &i__1, nrhs, &c_b9, &a[(a_dim1 << 1) + + 1], lda, &b[b_dim1 + 2], ldb); + } + +/* 2) Solve with triangular matrix T */ + +/* Compute T \ B -> B [ T \ (U**T \P**T * B) ] */ + + i__1 = *lda + 1; + clacpy_("F", &c__1, n, &a[a_dim1 + 1], &i__1, &work[*n], &c__1); + if (*n > 1) { + i__1 = *n - 1; + i__2 = *lda + 1; + clacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[1], + &c__1); + i__1 = *n - 1; + i__2 = *lda + 1; + clacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[*n + * 2], &c__1); + } + cgtsv_(n, nrhs, &work[1], &work[*n], &work[*n * 2], &b[b_offset], ldb, + info); + +/* 3) Backward substitution with U */ + + if (*n > 1) { + +/* Compute U \ B -> B [ U \ (T \ (U**T \P**T * B) ) ] */ + + i__1 = *n - 1; + ctrsm_("L", "U", "N", "U", &i__1, nrhs, &c_b9, &a[(a_dim1 << 1) + + 1], lda, &b[b_dim1 + 2], ldb); + +/* Pivot, P * B -> B [ P * (U**T \ (T \ (U \P**T * B) )) ] */ + + for (k = *n; k >= 1; --k) { + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + } + + } else { + +/* Solve A*X = B, where A = L*T*L**T. */ + +/* 1) Forward substitution with L */ + + if (*n > 1) { + +/* Pivot, P**T * B -> B */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute L \ B -> B [ (L \P**T * B) ] */ + + i__1 = *n - 1; + ctrsm_("L", "L", "N", "U", &i__1, nrhs, &c_b9, &a[a_dim1 + 2], + lda, &b[b_dim1 + 2], ldb); + } + +/* 2) Solve with triangular matrix T */ + + +/* Compute T \ B -> B [ T \ (L \P**T * B) ] */ + + i__1 = *lda + 1; + clacpy_("F", &c__1, n, &a[a_dim1 + 1], &i__1, &work[*n], &c__1); + if (*n > 1) { + i__1 = *n - 1; + i__2 = *lda + 1; + clacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[1], &c__1); + i__1 = *n - 1; + i__2 = *lda + 1; + clacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[*n * 2], & + c__1); + } + cgtsv_(n, nrhs, &work[1], &work[*n], &work[*n * 2], &b[b_offset], ldb, + info); + +/* 3) Backward substitution with L**T */ + + if (*n > 1) { + +/* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] */ + + i__1 = *n - 1; + ctrsm_("L", "L", "T", "U", &i__1, nrhs, &c_b9, &a[a_dim1 + 2], + lda, &b[b_dim1 + 2], ldb); + +/* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ] */ + + for (k = *n; k >= 1; --k) { + kp = ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + } + + } + + return 0; + +/* End of CSYTRS_AA */ + +} /* csytrs_aa__ */ + diff --git a/lapack-netlib/SRC/csytrs_aa_2stage.c b/lapack-netlib/SRC/csytrs_aa_2stage.c new file mode 100644 index 000000000..5690bef47 --- /dev/null +++ b/lapack-netlib/SRC/csytrs_aa_2stage.c @@ -0,0 +1,690 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRS_AA_2STAGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRS_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRS_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, IPIV, */ +/* IPIV2, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LTB, LDB, INFO */ +/* INTEGER IPIV( * ), IPIV2( * ) */ +/* COMPLEX A( LDA, * ), TB( * ), B( LDB, * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRS_AA_2STAGE solves a system of linear equations A*X = B with a complex */ +/* > symmetric matrix A using the factorization A = U**T*T*U or */ +/* > A = L*T*L**T computed by CSYTRF_AA_2STAGE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U**T*T*U; */ +/* > = 'L': Lower triangular, form is A = L*T*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] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > Details of factors computed by CSYTRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TB */ +/* > \verbatim */ +/* > TB is COMPLEX array, dimension (LTB) */ +/* > Details of factors computed by CSYTRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LTB */ +/* > \verbatim */ +/* > LTB is INTEGER */ +/* > The size of the array TB. LTB >= 4*N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges as computed by */ +/* > CSYTRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV2 */ +/* > \verbatim */ +/* > IPIV2 is INTEGER array, dimension (N) */ +/* > Details of the interchanges as computed by */ +/* > CSYTRF_AA_2STAGE. */ +/* > \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 November 2017 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int csytrs_aa_2stage_(char *uplo, integer *n, integer *nrhs, + complex *a, integer *lda, complex *tb, integer *ltb, integer *ipiv, + integer *ipiv2, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer ldtb; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cgbtrs_( + char *, integer *, integer *, integer *, integer *, complex *, + integer *, integer *, complex *, integer *, integer *), + claswp_(integer *, complex *, integer *, integer *, integer *, + integer *, integer *); + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tb; + --ipiv; + --ipiv2; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ltb < *n << 2) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRS_AA_2STAGE", &i__1, (ftnlen)16); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Read NB and compute LDTB */ + + nb = (integer) tb[1].r; + ldtb = *ltb / *n; + + if (upper) { + +/* Solve A*X = B, where A = U**T*T*U. */ + + if (*n > nb) { + +/* Pivot, P**T * B -> B */ + + i__1 = nb + 1; + claswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1); + +/* Compute (U**T \ B) -> B [ (U**T \P**T * B) ] */ + + i__1 = *n - nb; + ctrsm_("L", "U", "T", "U", &i__1, nrhs, &c_b1, &a[(nb + 1) * + a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb); + + } + +/* Compute T \ B -> B [ T \ (U**T \P**T * B) ] */ + + cgbtrs_("N", n, &nb, &nb, nrhs, &tb[1], &ldtb, &ipiv2[1], &b[b_offset] + , ldb, info); + if (*n > nb) { + +/* Compute (U \ B) -> B [ U \ (T \ (U**T \P**T * B) ) ] */ + + i__1 = *n - nb; + ctrsm_("L", "U", "N", "U", &i__1, nrhs, &c_b1, &a[(nb + 1) * + a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb); + +/* Pivot, P * B -> B [ P * (U \ (T \ (U**T \P**T * B) )) ] */ + + i__1 = nb + 1; + claswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1); + + } + + } else { + +/* Solve A*X = B, where A = L*T*L**T. */ + + if (*n > nb) { + +/* Pivot, P**T * B -> B */ + + i__1 = nb + 1; + claswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1); + +/* Compute (L \ B) -> B [ (L \P**T * B) ] */ + + i__1 = *n - nb; + ctrsm_("L", "L", "N", "U", &i__1, nrhs, &c_b1, &a[nb + 1 + a_dim1] + , lda, &b[nb + 1 + b_dim1], ldb); + + } + +/* Compute T \ B -> B [ T \ (L \P**T * B) ] */ + + cgbtrs_("N", n, &nb, &nb, nrhs, &tb[1], &ldtb, &ipiv2[1], &b[b_offset] + , ldb, info); + if (*n > nb) { + +/* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] */ + + i__1 = *n - nb; + ctrsm_("L", "L", "T", "U", &i__1, nrhs, &c_b1, &a[nb + 1 + a_dim1] + , lda, &b[nb + 1 + b_dim1], ldb); + +/* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ] */ + + i__1 = nb + 1; + claswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1); + + } + } + + return 0; + +/* End of CSYTRS_AA_2STAGE */ + +} /* csytrs_aa_2stage__ */ + diff --git a/lapack-netlib/SRC/csytrs_rook.c b/lapack-netlib/SRC/csytrs_rook.c new file mode 100644 index 000000000..61e7d43f8 --- /dev/null +++ b/lapack-netlib/SRC/csytrs_rook.c @@ -0,0 +1,976 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CSYTRS_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CSYTRS_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CSYTRS_ROOK solves a system of linear equations A*X = B with */ +/* > a complex symmetric matrix A using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by CSYTRF_ROOK. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**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] 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,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 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 csytrs_rook_(char *uplo, integer *n, integer *nrhs, + complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, 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 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CSYTRS_ROOK", &i__1, (ftnlen)11); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**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; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + 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, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + cscal_(nrhs, &q__1, &b[k + b_dim1], ldb); + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */ + + kp = -ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k - 1]; + 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. */ + + if (k > 2) { + i__1 = k - 2; + q__1.r = -1.f, q__1.i = 0.f; + cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &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, &a[(k - 1) * a_dim1 + 1], &c__1, & + b[k - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = k - 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[k + k * a_dim1], &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: */ + } + 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; +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. */ + + if (k > 1) { + 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, &a[ + k * a_dim1 + 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(U**T(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k > 1) { + 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, &a[ + k * a_dim1 + 1], &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, &a[ + (k + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). */ + + kp = -ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k + 1]; + if (kp != k + 1) { + cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L**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; +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, &a[k + 1 + k * a_dim1], &c__1, &b[ + k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + cscal_(nrhs, &q__1, &b[k + b_dim1], ldb); + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) */ + + kp = -ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k + 1]; + 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, &a[k + 2 + k * a_dim1], &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, &a[k + 2 + (k + 1) * a_dim1], & + c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], + ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = k + 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + c_div(&q__1, &a[k + k * a_dim1], &akm1k); + akm1.r = q__1.r, akm1.i = q__1.i; + c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &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: */ + } + 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; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L**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, &a[k + 1 + k * a_dim1], &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, &a[k + 1 + k * a_dim1], &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, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b1, &b[k + - 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */ + + kp = -ipiv[k]; + if (kp != k) { + cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k - 1]; + if (kp != k - 1) { + cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of CSYTRS_ROOK */ + +} /* csytrs_rook__ */ + diff --git a/lapack-netlib/SRC/ctbcon.c b/lapack-netlib/SRC/ctbcon.c new file mode 100644 index 000000000..4deee7ffd --- /dev/null +++ b/lapack-netlib/SRC/ctbcon.c @@ -0,0 +1,686 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTBCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTBCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, */ +/* RWORK, INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* REAL RCOND */ +/* REAL RWORK( * ) */ +/* COMPLEX AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTBCON estimates the reciprocal of the condition number of a */ +/* > triangular band matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit 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 superdiagonals or subdiagonals of the */ +/* > triangular band 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). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \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 ctbcon_(char *norm, char *uplo, char *diag, integer *n, + integer *kd, complex *ab, integer *ldab, 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, kase1; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + real anorm; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + real xnorm; + integer ix; + extern integer icamax_(integer *, complex *, integer *); + extern real clantb_(char *, char *, char *, integer *, integer *, complex + *, integer *, real *), slamch_(char *); + extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, + integer *, integer *, complex *, integer *, complex *, real *, + real *, integer *), xerbla_(char * + , integer *, ftnlen); + real ainvnm; + extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer + *); + logical onenrm; + char normin[1]; + real smlnum; + logical nounit; + + +/* -- 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"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTBCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.f; + return 0; + } + + *rcond = 0.f; + smlnum = slamch_("Safe minimum") * (real) f2cmax(*n,1); + +/* Compute the 1-norm of the triangular matrix A or A**H. */ + + anorm = clantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.f) { + +/* Estimate the 1-norm of the inverse of A. */ + + ainvnm = 0.f; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + clatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scale, &rwork[1], info); + } else { + +/* Multiply by inv(A**H). */ + + clatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scale, &rwork[1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.f) { + ix = icamax_(n, &work[1], &c__1); + i__1 = ix; + xnorm = (r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& + work[ix]), abs(r__2)); + if (scale < xnorm * 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 / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of CTBCON */ + +} /* ctbcon_ */ + diff --git a/lapack-netlib/SRC/ctbrfs.c b/lapack-netlib/SRC/ctbrfs.c new file mode 100644 index 000000000..931c2354d --- /dev/null +++ b/lapack-netlib/SRC/ctbrfs.c @@ -0,0 +1,1033 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTBRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTBRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, */ +/* LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX AB( LDAB, * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTBRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular band */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by CTBTRS or some other */ +/* > means before entering this routine. CTBRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit 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 superdiagonals or subdiagonals of the */ +/* > triangular band matrix A. 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 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). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 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] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > The 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 */ + +/* 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 ctbrfs_(char *uplo, char *trans, char *diag, integer *n, + integer *kd, integer *nrhs, complex *ab, integer *ldab, 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, 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 ctbmv_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *), ccopy_(integer *, complex *, integer *, complex * + , integer *), ctbsv_(char *, char *, char *, integer *, integer *, + complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, + complex *, integer *); + 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); + logical notran; + char transn[1], transt[1]; + logical nounit; + 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; + 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"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + 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 (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *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_("CTBRFS", &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; + } + + if (notran) { + *(unsigned char *)transn = 'N'; + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transn = 'C'; + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *kd + 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) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); + ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], & + c__1); + q__1.r = -1.f, q__1.i = 0.f; + caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + 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)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k; + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + i__3 = *kd + 1 + i__ - k + k * ab_dim1; + rwork[i__] += ((r__1 = ab[i__3].r, abs(r__1)) + ( + r__2 = r_imag(&ab[*kd + 1 + i__ - k + k * + ab_dim1]), abs(r__2))) * xk; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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)); +/* Computing MAX */ + i__5 = 1, i__3 = k - *kd; + i__4 = k - 1; + for (i__ = f2cmax(i__5,i__3); i__ <= i__4; ++i__) { + i__5 = *kd + 1 + i__ - k + k * ab_dim1; + rwork[i__] += ((r__1 = ab[i__5].r, abs(r__1)) + ( + r__2 = r_imag(&ab[*kd + 1 + i__ - k + k * + ab_dim1]), abs(r__2))) * xk; +/* L50: */ + } + rwork[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__4 = k + j * x_dim1; + xk = (r__1 = x[i__4].r, abs(r__1)) + (r__2 = r_imag(& + x[k + j * x_dim1]), abs(r__2)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = f2cmin(i__5,i__3); + for (i__ = k; i__ <= i__4; ++i__) { + i__5 = i__ + 1 - k + k * ab_dim1; + rwork[i__] += ((r__1 = ab[i__5].r, abs(r__1)) + ( + r__2 = r_imag(&ab[i__ + 1 - k + k * + ab_dim1]), abs(r__2))) * xk; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__4 = k + j * x_dim1; + xk = (r__1 = x[i__4].r, abs(r__1)) + (r__2 = r_imag(& + x[k + j * x_dim1]), abs(r__2)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = f2cmin(i__5,i__3); + for (i__ = k + 1; i__ <= i__4; ++i__) { + i__5 = i__ + 1 - k + k * ab_dim1; + rwork[i__] += ((r__1 = ab[i__5].r, abs(r__1)) + ( + r__2 = r_imag(&ab[i__ + 1 - k + k * + ab_dim1]), abs(r__2))) * xk; +/* L90: */ + } + rwork[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**H)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; +/* Computing MAX */ + i__4 = 1, i__5 = k - *kd; + i__3 = k; + for (i__ = f2cmax(i__4,i__5); i__ <= i__3; ++i__) { + i__4 = *kd + 1 + i__ - k + k * ab_dim1; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ab[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ab[*kd + 1 + i__ - k + k * + ab_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))); +/* L110: */ + } + rwork[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * x_dim1; + s = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[ + k + j * x_dim1]), abs(r__2)); +/* 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 = *kd + 1 + i__ - k + k * ab_dim1; + i__4 = i__ + j * x_dim1; + s += ((r__1 = ab[i__3].r, abs(r__1)) + (r__2 = + r_imag(&ab[*kd + 1 + i__ - k + 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))); +/* L130: */ + } + rwork[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = f2cmin(i__3,i__4); + for (i__ = k; i__ <= i__5; ++i__) { + i__3 = i__ + 1 - k + k * ab_dim1; + i__4 = i__ + j * x_dim1; + s += ((r__1 = ab[i__3].r, abs(r__1)) + (r__2 = + r_imag(&ab[i__ + 1 - k + 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))); +/* L150: */ + } + rwork[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__5 = k + j * x_dim1; + s = (r__1 = x[i__5].r, abs(r__1)) + (r__2 = r_imag(&x[ + k + j * x_dim1]), abs(r__2)); +/* 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 = i__ + 1 - k + k * ab_dim1; + i__4 = i__ + j * x_dim1; + s += ((r__1 = ab[i__3].r, abs(r__1)) + (r__2 = + r_imag(&ab[i__ + 1 - k + 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))); +/* L170: */ + } + rwork[k] += s; +/* L180: */ + } + } + } + } + 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); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (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; + } +/* L200: */ + } + + kase = 0; +L210: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**H). */ + + ctbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[ + 1], &c__1); + 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; +/* L220: */ + } + } else { + +/* Multiply by inv(op(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; +/* L230: */ + } + ctbsv_(uplo, transn, diag, n, kd, &ab[ab_offset], ldab, &work[ + 1], &c__1); + } + goto L210; + } + +/* 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); +/* L240: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of CTBRFS */ + +} /* ctbrfs_ */ + diff --git a/lapack-netlib/SRC/ctbtrs.c b/lapack-netlib/SRC/ctbtrs.c new file mode 100644 index 000000000..d9b223b82 --- /dev/null +++ b/lapack-netlib/SRC/ctbtrs.c @@ -0,0 +1,646 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTBTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTBTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, */ +/* LDB, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, N, NRHS */ +/* COMPLEX AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTBTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B, A**T * X = B, or A**H * X = B, */ +/* > */ +/* > where A is a triangular band matrix of order N, and B is an */ +/* > N-by-NRHS matrix. A check is made to verify that A is nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit 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 superdiagonals or subdiagonals of the */ +/* > triangular band matrix A. 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 upper or lower triangular band matrix A, stored in the */ +/* > first kd+1 rows of AB. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(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). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \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, if INFO = 0, 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 */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the */ +/* > solutions X have 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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int ctbtrs_(char *uplo, char *trans, char *diag, 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, i__2; + + /* 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); + logical nounit; + + +/* -- 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; + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTBTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *kd + 1 + *info * ab_dim1; + if (ab[i__2].r == 0.f && ab[i__2].i == 0.f) { + return 0; + } +/* L10: */ + } + } else { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info * ab_dim1 + 1; + if (ab[i__2].r == 0.f && ab[i__2].i == 0.f) { + return 0; + } +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * X = B, A**T * X = B, or A**H * X = B. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ctbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 + + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of CTBTRS */ + +} /* ctbtrs_ */ + diff --git a/lapack-netlib/SRC/ctfsm.c b/lapack-netlib/SRC/ctfsm.c new file mode 100644 index 000000000..a296c2dfe --- /dev/null +++ b/lapack-netlib/SRC/ctfsm.c @@ -0,0 +1,1464 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTFSM solves a matrix equation (one operand is a triangular matrix in RFP format). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTFSM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, */ +/* B, LDB ) */ + +/* CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO */ +/* INTEGER LDB, M, N */ +/* COMPLEX ALPHA */ +/* COMPLEX A( 0: * ), B( 0: LDB-1, 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 3 BLAS like routine for A in RFP Format. */ +/* > */ +/* > CTFSM solves the matrix equation */ +/* > */ +/* > op( A )*X = alpha*B or X*op( A ) = alpha*B */ +/* > */ +/* > where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ +/* > non-unit, upper or lower triangular matrix and op( A ) is one of */ +/* > */ +/* > op( A ) = A or op( A ) = A**H. */ +/* > */ +/* > A is in Rectangular Full Packed (RFP) Format. */ +/* > */ +/* > The matrix X is overwritten on B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal Form of RFP A is stored; */ +/* > = 'C': The Conjugate-transpose Form of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > On entry, SIDE specifies whether op( A ) appears on the left */ +/* > or right of X as follows: */ +/* > */ +/* > SIDE = 'L' or 'l' op( A )*X = alpha*B. */ +/* > */ +/* > SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the RFP matrix A came from */ +/* > an upper or lower triangular matrix as follows: */ +/* > UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */ +/* > UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > On entry, TRANS specifies the form of op( A ) to be used */ +/* > in the matrix multiplication as follows: */ +/* > */ +/* > TRANS = 'N' or 'n' op( A ) = A. */ +/* > */ +/* > TRANS = 'C' or 'c' op( A ) = conjg( A' ). */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > On entry, DIAG specifies whether or not RFP A is unit */ +/* > triangular as follows: */ +/* > */ +/* > DIAG = 'U' or 'u' A is assumed to be unit triangular. */ +/* > */ +/* > DIAG = 'N' or 'n' A is not assumed to be unit */ +/* > triangular. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of B. M must be at */ +/* > least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of B. N must be */ +/* > at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX */ +/* > On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* > zero then A is not referenced and B need not be set before */ +/* > entry. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (N*(N+1)/2) */ +/* > NT = N*(N+1)/2. On entry, the 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 either in normal or */ +/* > conjugate-transpose Format. If UPLO = 'L' the RFP A contains */ +/* > the NT elements of lower packed A either in normal or */ +/* > conjugate-transpose Format. 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 is N when is odd. */ +/* > See the Note below for more details. Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > Before entry, the leading m by n part of the array B must */ +/* > contain the right-hand side matrix B, and on exit is */ +/* > overwritten by the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > On entry, LDB specifies the first dimension of B as declared */ +/* > in the calling (sub) program. LDB must be at least */ +/* > f2cmax( 1, m ). */ +/* > 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 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 ctfsm_(char *transr, char *side, char *uplo, char *trans, + char *diag, integer *m, integer *n, complex *alpha, complex *a, + complex *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + integer info, i__, j, k; + logical normaltransr; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + logical lside; + extern logical lsame_(char *, char *); + logical lower; + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer m1, m2, n1, n2; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical misodd, nisodd, notrans; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb - 1 - 0 + 1; + b_offset = 0 + b_dim1 * 0; + b -= b_offset; + + /* Function Body */ + info = 0; + normaltransr = lsame_(transr, "N"); + lside = lsame_(side, "L"); + lower = lsame_(uplo, "L"); + notrans = lsame_(trans, "N"); + if (! normaltransr && ! lsame_(transr, "C")) { + info = -1; + } else if (! lside && ! lsame_(side, "R")) { + info = -2; + } else if (! lower && ! lsame_(uplo, "U")) { + info = -3; + } else if (! notrans && ! lsame_(trans, "C")) { + info = -4; + } else if (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + info = -5; + } else if (*m < 0) { + info = -6; + } else if (*n < 0) { + info = -7; + } else if (*ldb < f2cmax(1,*m)) { + info = -11; + } + if (info != 0) { + i__1 = -info; + xerbla_("CTFSM ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Quick return when ALPHA.EQ.(0E+0,0E+0) */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + i__1 = *n - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *m - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + return 0; + } + + if (lside) { + +/* SIDE = 'L' */ + +/* A is M-by-M. */ +/* If M is odd, set NISODD = .TRUE., and M1 and M2. */ +/* If M is even, NISODD = .FALSE., and M. */ + + if (*m % 2 == 0) { + misodd = FALSE_; + k = *m / 2; + } else { + misodd = TRUE_; + if (lower) { + m2 = *m / 2; + m1 = *m - m2; + } else { + m1 = *m / 2; + m2 = *m - m1; + } + } + + if (misodd) { + +/* SIDE = 'L' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'L', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + ctrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + } else { + ctrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &m2, n, &m1, &q__1, &a[m1], m, & + b[b_offset], ldb, alpha, &b[m1], ldb); + ctrsm_("L", "U", "C", diag, &m2, n, &c_b1, &a[*m], + m, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'C' */ + + if (*m == 1) { + ctrsm_("L", "L", "C", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + } else { + ctrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m], + m, &b[m1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &m1, n, &m2, &q__1, &a[m1], m, & + b[m1], ldb, alpha, &b[b_offset], ldb); + ctrsm_("L", "L", "C", diag, &m1, n, &c_b1, a, m, & + b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + ctrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m, + &b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &m2, n, &m1, &q__1, a, m, &b[ + b_offset], ldb, alpha, &b[m1], ldb); + ctrsm_("L", "U", "C", diag, &m2, n, &c_b1, &a[m1], m, + &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'C' */ + + ctrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m, + &b[m1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &m1, n, &m2, &q__1, a, m, &b[m1], + ldb, alpha, &b[b_offset], ldb); + ctrsm_("L", "L", "C", diag, &m1, n, &c_b1, &a[m2], m, + &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is odd, and TRANSR = 'C' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + ctrsm_("L", "U", "C", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + } else { + ctrsm_("L", "U", "C", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &m2, n, &m1, &q__1, &a[m1 * m1], + &m1, &b[b_offset], ldb, alpha, &b[m1], + ldb); + ctrsm_("L", "L", "N", diag, &m2, n, &c_b1, &a[1], + &m1, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and */ +/* TRANS = 'C' */ + + if (*m == 1) { + ctrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + } else { + ctrsm_("L", "L", "C", diag, &m2, n, alpha, &a[1], + &m1, &b[m1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &m1, n, &m2, &q__1, &a[m1 * m1], + &m1, &b[m1], ldb, alpha, &b[b_offset], + ldb); + ctrsm_("L", "U", "N", diag, &m1, n, &c_b1, a, &m1, + &b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and */ +/* TRANS = 'N' */ + + ctrsm_("L", "U", "C", diag, &m1, n, alpha, &a[m2 * m2] + , &m2, &b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &m2, n, &m1, &q__1, a, &m2, &b[ + b_offset], ldb, alpha, &b[m1], ldb); + ctrsm_("L", "L", "N", diag, &m2, n, &c_b1, &a[m1 * m2] + , &m2, &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and */ +/* TRANS = 'C' */ + + ctrsm_("L", "L", "C", diag, &m2, n, alpha, &a[m1 * m2] + , &m2, &b[m1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &m1, n, &m2, &q__1, a, &m2, &b[m1], + ldb, alpha, &b[b_offset], ldb); + ctrsm_("L", "U", "N", diag, &m1, n, &c_b1, &a[m2 * m2] + , &m2, &b[b_offset], ldb); + + } + + } + + } + + } else { + +/* SIDE = 'L' and N is even */ + + if (normaltransr) { + +/* SIDE = 'L', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + ctrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], & + i__1, &b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *m + 1; + cgemm_("N", "N", &k, n, &k, &q__1, &a[k + 1], &i__1, & + b[b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + ctrsm_("L", "U", "C", diag, &k, n, &c_b1, a, &i__1, & + b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'C' */ + + i__1 = *m + 1; + ctrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, & + b[k], ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *m + 1; + cgemm_("C", "N", &k, n, &k, &q__1, &a[k + 1], &i__1, & + b[k], ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + ctrsm_("L", "L", "C", diag, &k, n, &c_b1, &a[1], & + i__1, &b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + ctrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], & + i__1, &b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *m + 1; + cgemm_("C", "N", &k, n, &k, &q__1, a, &i__1, &b[ + b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + ctrsm_("L", "U", "C", diag, &k, n, &c_b1, &a[k], & + i__1, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'C' */ + i__1 = *m + 1; + ctrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], & + i__1, &b[k], ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *m + 1; + cgemm_("N", "N", &k, n, &k, &q__1, a, &i__1, &b[k], + ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + ctrsm_("L", "L", "C", diag, &k, n, &c_b1, &a[k + 1], & + i__1, &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is even, and TRANSR = 'C' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', */ +/* and TRANS = 'N' */ + + ctrsm_("L", "U", "C", diag, &k, n, alpha, &a[k], &k, & + b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &k, n, &k, &q__1, &a[k * (k + 1)], & + k, &b[b_offset], ldb, alpha, &b[k], ldb); + ctrsm_("L", "L", "N", diag, &k, n, &c_b1, a, &k, &b[k] + , ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', */ +/* and TRANS = 'C' */ + + ctrsm_("L", "L", "C", diag, &k, n, alpha, a, &k, &b[k] + , ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &k, n, &k, &q__1, &a[k * (k + 1)], & + k, &b[k], ldb, alpha, &b[b_offset], ldb); + ctrsm_("L", "U", "N", diag, &k, n, &c_b1, &a[k], &k, & + b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', */ +/* and TRANS = 'N' */ + + ctrsm_("L", "U", "C", diag, &k, n, alpha, &a[k * (k + + 1)], &k, &b[b_offset], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &k, n, &k, &q__1, a, &k, &b[b_offset] + , ldb, alpha, &b[k], ldb); + ctrsm_("L", "L", "N", diag, &k, n, &c_b1, &a[k * k], & + k, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', */ +/* and TRANS = 'C' */ + + ctrsm_("L", "L", "C", diag, &k, n, alpha, &a[k * k], & + k, &b[k], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &k, n, &k, &q__1, a, &k, &b[k], ldb, + alpha, &b[b_offset], ldb); + ctrsm_("L", "U", "N", diag, &k, n, &c_b1, &a[k * (k + + 1)], &k, &b[b_offset], ldb); + + } + + } + + } + + } + + } else { + +/* SIDE = 'R' */ + +/* A is N-by-N. */ +/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ +/* If N is even, NISODD = .FALSE., and K. */ + + if (*n % 2 == 0) { + nisodd = FALSE_; + k = *n / 2; + } else { + nisodd = TRUE_; + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + } + + if (nisodd) { + +/* SIDE = 'R' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'R', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + ctrsm_("R", "U", "C", diag, m, &n2, alpha, &a[*n], n, + &b[n1 * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &n1, &n2, &q__1, &b[n1 * b_dim1], + ldb, &a[n1], n, alpha, b, ldb); + ctrsm_("R", "L", "N", diag, m, &n1, &c_b1, a, n, b, + ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'C' */ + + ctrsm_("R", "L", "C", diag, m, &n1, alpha, a, n, b, + ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &n2, &n1, &q__1, b, ldb, &a[n1], + n, alpha, &b[n1 * b_dim1], ldb); + ctrsm_("R", "U", "N", diag, m, &n2, &c_b1, &a[*n], n, + &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + ctrsm_("R", "L", "C", diag, m, &n1, alpha, &a[n2], n, + b, ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &n2, &n1, &q__1, b, ldb, a, n, + alpha, &b[n1 * b_dim1], ldb); + ctrsm_("R", "U", "N", diag, m, &n2, &c_b1, &a[n1], n, + &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'C' */ + + ctrsm_("R", "U", "C", diag, m, &n2, alpha, &a[n1], n, + &b[n1 * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &n1, &n2, &q__1, &b[n1 * b_dim1], + ldb, a, n, alpha, b, ldb); + ctrsm_("R", "L", "N", diag, m, &n1, &c_b1, &a[n2], n, + b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is odd, and TRANSR = 'C' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and */ +/* TRANS = 'N' */ + + ctrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1, + &b[n1 * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &n1, &n2, &q__1, &b[n1 * b_dim1], + ldb, &a[n1 * n1], &n1, alpha, b, ldb); + ctrsm_("R", "U", "C", diag, m, &n1, &c_b1, a, &n1, b, + ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and */ +/* TRANS = 'C' */ + + ctrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b, + ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &n2, &n1, &q__1, b, ldb, &a[n1 * + n1], &n1, alpha, &b[n1 * b_dim1], ldb); + ctrsm_("R", "L", "C", diag, m, &n2, &c_b1, &a[1], &n1, + &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and */ +/* TRANS = 'N' */ + + ctrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2] + , &n2, b, ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &n2, &n1, &q__1, b, ldb, a, &n2, + alpha, &b[n1 * b_dim1], ldb); + ctrsm_("R", "L", "C", diag, m, &n2, &c_b1, &a[n1 * n2] + , &n2, &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and */ +/* TRANS = 'C' */ + + ctrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2] + , &n2, &b[n1 * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &n1, &n2, &q__1, &b[n1 * b_dim1], + ldb, a, &n2, alpha, b, ldb); + ctrsm_("R", "U", "C", diag, m, &n1, &c_b1, &a[n2 * n2] + , &n2, b, ldb); + + } + + } + + } + + } else { + +/* SIDE = 'R' and N is even */ + + if (normaltransr) { + +/* SIDE = 'R', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + ctrsm_("R", "U", "C", diag, m, &k, alpha, a, &i__1, & + b[k * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *n + 1; + cgemm_("N", "N", m, &k, &k, &q__1, &b[k * b_dim1], + ldb, &a[k + 1], &i__1, alpha, b, ldb); + i__1 = *n + 1; + ctrsm_("R", "L", "N", diag, m, &k, &c_b1, &a[1], & + i__1, b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'C' */ + + i__1 = *n + 1; + ctrsm_("R", "L", "C", diag, m, &k, alpha, &a[1], & + i__1, b, ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *n + 1; + cgemm_("N", "C", m, &k, &k, &q__1, b, ldb, &a[k + 1], + &i__1, alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + ctrsm_("R", "U", "N", diag, m, &k, &c_b1, a, &i__1, & + b[k * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + ctrsm_("R", "L", "C", diag, m, &k, alpha, &a[k + 1], & + i__1, b, ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *n + 1; + cgemm_("N", "N", m, &k, &k, &q__1, b, ldb, a, &i__1, + alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + ctrsm_("R", "U", "N", diag, m, &k, &c_b1, &a[k], & + i__1, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'C' */ + + i__1 = *n + 1; + ctrsm_("R", "U", "C", diag, m, &k, alpha, &a[k], & + i__1, &b[k * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *n + 1; + cgemm_("N", "C", m, &k, &k, &q__1, &b[k * b_dim1], + ldb, a, &i__1, alpha, b, ldb); + i__1 = *n + 1; + ctrsm_("R", "L", "N", diag, m, &k, &c_b1, &a[k + 1], & + i__1, b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is even, and TRANSR = 'C' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', */ +/* and TRANS = 'N' */ + + ctrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k + * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &k, &k, &q__1, &b[k * b_dim1], + ldb, &a[(k + 1) * k], &k, alpha, b, ldb); + ctrsm_("R", "U", "C", diag, m, &k, &c_b1, &a[k], &k, + b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', */ +/* and TRANS = 'C' */ + + ctrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k, + b, ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &k, &k, &q__1, b, ldb, &a[(k + 1) + * k], &k, alpha, &b[k * b_dim1], ldb); + ctrsm_("R", "L", "C", diag, m, &k, &c_b1, a, &k, &b[k + * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', */ +/* and TRANS = 'N' */ + + ctrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) * + k], &k, b, ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &k, &k, &q__1, b, ldb, a, &k, + alpha, &b[k * b_dim1], ldb); + ctrsm_("R", "L", "C", diag, m, &k, &c_b1, &a[k * k], & + k, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', */ +/* and TRANS = 'C' */ + + ctrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], & + k, &b[k * b_dim1], ldb); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &k, &k, &q__1, &b[k * b_dim1], + ldb, a, &k, alpha, b, ldb); + ctrsm_("R", "U", "C", diag, m, &k, &c_b1, &a[(k + 1) * + k], &k, b, ldb); + + } + + } + + } + + } + } + + return 0; + +/* End of CTFSM */ + +} /* ctfsm_ */ + diff --git a/lapack-netlib/SRC/ctftri.c b/lapack-netlib/SRC/ctftri.c new file mode 100644 index 000000000..717d1c031 --- /dev/null +++ b/lapack-netlib/SRC/ctftri.c @@ -0,0 +1,924 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTFTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTFTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) */ + +/* CHARACTER TRANSR, UPLO, DIAG */ +/* INTEGER INFO, N */ +/* COMPLEX A( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTFTRI computes the inverse of a triangular matrix A stored in RFP */ +/* > format. */ +/* > */ +/* > This is a Level 3 BLAS version of the algorithm. */ +/* > \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': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit 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 ( N*(N+1)/2 ); */ +/* > On entry, the triangular 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 nt */ +/* > 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 (triangular) 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, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can 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 ctftri_(char *transr, char *uplo, char *diag, integer *n, + complex *a, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + complex q__1; + + /* Local variables */ + integer k; + logical normaltransr; + 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 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. */ + + *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 (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTFTRI", &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) */ + + ctrtri_("L", diag, &n1, a, n, info); + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + ctrmm_("R", "L", "N", diag, &n2, &n1, &q__1, a, n, &a[n1], n); + ctrtri_("U", diag, &n2, &a[*n], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + ctrmm_("L", "U", "C", diag, &n2, &n1, &c_b1, &a[*n], n, &a[n1] + , n); + + } 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) */ + + ctrtri_("L", diag, &n1, &a[n2], n, info) + ; + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + ctrmm_("L", "L", "C", diag, &n1, &n2, &q__1, &a[n2], n, a, n); + ctrtri_("U", diag, &n2, &a[n1], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + ctrmm_("R", "U", "N", diag, &n1, &n2, &c_b1, &a[n1], n, a, n); + + } + + } 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) */ + + ctrtri_("U", diag, &n1, a, &n1, info); + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + ctrmm_("L", "U", "N", diag, &n1, &n2, &q__1, a, &n1, &a[n1 * + n1], &n1); + ctrtri_("L", diag, &n2, &a[1], &n1, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + ctrmm_("R", "L", "C", diag, &n1, &n2, &c_b1, &a[1], &n1, &a[ + n1 * n1], &n1); + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */ + + ctrtri_("U", diag, &n1, &a[n2 * n2], &n2, info); + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + ctrmm_("R", "U", "C", diag, &n2, &n1, &q__1, &a[n2 * n2], &n2, + a, &n2); + ctrtri_("L", diag, &n2, &a[n1 * n2], &n2, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + ctrmm_("L", "L", "N", diag, &n2, &n1, &c_b1, &a[n1 * n2], &n2, + a, &n2); + } + + } + + } 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; + ctrtri_("L", diag, &k, &a[1], &i__1, info); + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *n + 1; + i__2 = *n + 1; + ctrmm_("R", "L", "N", diag, &k, &k, &q__1, &a[1], &i__1, &a[k + + 1], &i__2); + i__1 = *n + 1; + ctrtri_("U", diag, &k, a, &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + ctrmm_("L", "U", "C", diag, &k, &k, &c_b1, a, &i__1, &a[k + 1] + , &i__2); + + } 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; + ctrtri_("L", diag, &k, &a[k + 1], &i__1, info); + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + i__1 = *n + 1; + i__2 = *n + 1; + ctrmm_("L", "L", "C", diag, &k, &k, &q__1, &a[k + 1], &i__1, + a, &i__2); + i__1 = *n + 1; + ctrtri_("U", diag, &k, &a[k], &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + ctrmm_("R", "U", "N", diag, &k, &k, &c_b1, &a[k], &i__1, a, & + i__2); + } + } 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 */ + + ctrtri_("U", diag, &k, &a[k], &k, info); + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + ctrmm_("L", "U", "N", diag, &k, &k, &q__1, &a[k], &k, &a[k * ( + k + 1)], &k); + ctrtri_("L", diag, &k, a, &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + ctrmm_("R", "L", "C", diag, &k, &k, &c_b1, a, &k, &a[k * (k + + 1)], &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 */ + + ctrtri_("U", diag, &k, &a[k * (k + 1)], &k, info); + if (*info > 0) { + return 0; + } + q__1.r = -1.f, q__1.i = 0.f; + ctrmm_("R", "U", "C", diag, &k, &k, &q__1, &a[k * (k + 1)], & + k, a, &k); + ctrtri_("L", diag, &k, &a[k * k], &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + ctrmm_("L", "L", "N", diag, &k, &k, &c_b1, &a[k * k], &k, a, & + k); + } + } + } + + return 0; + +/* End of CTFTRI */ + +} /* ctftri_ */ + diff --git a/lapack-netlib/SRC/ctfttp.c b/lapack-netlib/SRC/ctfttp.c new file mode 100644 index 000000000..05b6d626e --- /dev/null +++ b/lapack-netlib/SRC/ctfttp.c @@ -0,0 +1,996 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard +packed format (TP). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTFTTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N */ +/* COMPLEX AP( 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTFTTP copies a triangular matrix A from rectangular full packed */ +/* > format (TF) to standard packed format (TP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF is in Normal format; */ +/* > = 'C': ARF is in Conjugate-transpose format; */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ARF */ +/* > \verbatim */ +/* > ARF is COMPLEX array, dimension ( N*(N+1)/2 ), */ +/* > On entry, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension ( N*(N+1)/2 ), */ +/* > On exit, 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[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 ctfttp_(char *transr, char *uplo, integer *n, complex * + arf, complex *ap, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + complex q__1; + + /* Local variables */ + integer i__, j, k; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, jp, js, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer lda, ijp; + + +/* -- 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_("CTFTTP", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + ap[0].r = arf[0].r, ap[0].i = arf[0].i; + } else { + r_cnjg(&q__1, arf); + ap[0].r = q__1.r, ap[0].i = q__1.i; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + lda = *n + 1; + } else { + nisodd = TRUE_; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* 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); lda = n */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + i__3 = ijp; + i__4 = ij; + ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + i__3 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++ijp; + } + } + + } 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) */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + i__3 = ijp; + i__4 = ij; + ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i; + ++ijp; + } + js += lda; + } + + } + + } 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 */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= + i__2; ij += i__3) { + i__4 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__4].r = q__1.r, ap[i__4].i = q__1.i; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ijp; + i__4 = ij; + ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i; + ++ijp; + } + js = js + lda + 1; + } + + } 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 */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ijp; + i__4 = ij; + ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + i__4 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__4].r = q__1.r, ap[i__4].i = q__1.i; + ++ijp; + } + } + + } + + } + + } 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) */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + i__3 = ijp; + i__4 = ij; + ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + i__3 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++ijp; + } + } + + } 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) */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + i__3 = ijp; + i__4 = ij; + ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i; + ++ijp; + } + js += lda; + } + + } + + } 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 */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : + ij <= i__2; ij += i__3) { + i__4 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__4].r = q__1.r, ap[i__4].i = q__1.i; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ijp; + i__4 = ij; + ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i; + ++ijp; + } + js = js + lda + 1; + } + + } 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 */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ijp; + i__4 = ij; + ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + i__4 = ijp; + r_cnjg(&q__1, &arf[ij]); + ap[i__4].r = q__1.r, ap[i__4].i = q__1.i; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of CTFTTP */ + +} /* ctfttp_ */ + diff --git a/lapack-netlib/SRC/ctfttr.c b/lapack-netlib/SRC/ctfttr.c new file mode 100644 index 000000000..ee11182ac --- /dev/null +++ b/lapack-netlib/SRC/ctfttr.c @@ -0,0 +1,1006 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard +full format (TR). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTFTTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N, LDA */ +/* COMPLEX A( 0: LDA-1, 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTFTTR copies a triangular matrix A from rectangular full packed */ +/* > format (TF) to standard full format (TR). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF is in Normal format; */ +/* > = 'C': ARF is in Conjugate-transpose format; */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ARF */ +/* > \verbatim */ +/* > ARF is COMPLEX array, dimension ( N*(N+1)/2 ), */ +/* > On entry, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > On exit, 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. */ +/* > \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 */ +/* > \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 ctfttr_(char *transr, char *uplo, integer *n, complex * + arf, 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 np1x2, i__, j, k, l; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer nx2; + + +/* -- 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 - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_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 (*lda < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTFTTR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + if (normaltransr) { + a[0].r = arf[0].r, a[0].i = arf[0].i; + } else { + r_cnjg(&q__1, arf); + a[0].r = q__1.r, a[0].i = q__1.i; + } + } + return 0; + } + +/* Size of array ARF(1:2,0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = TRUE_; + if (! lower) { + nx2 = *n + *n; + } + } + + 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); lda=n */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + i__3 = n2 + j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + } + + } 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); lda=n */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + i__3 = j - n1 + l * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + ij -= nx2; + } + + } + + } 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 */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + i__3 = i__ + (n1 + j) * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + } + + } 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 */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + i__3 = n2 + j + l * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + } + + } + + } + + } 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); lda=n+1 */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + i__3 = k + j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + } + + } 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); lda=n+1 */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + i__3 = j - k + l * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'C' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) */ +/* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : */ +/* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + i__3 = ij; + a[i__2].r = arf[i__3].r, a[i__2].i = arf[i__3].i; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + i__3 = i__ + (k + 1 + j) * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) */ +/* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) */ +/* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ij; + a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + i__3 = k + 1 + j + l * a_dim1; + r_cnjg(&q__1, &arf[ij]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ++ij; + } + } + +/* Note that here J = K-1 */ + + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + i__3 = ij; + a[i__2].r = arf[i__3].r, a[i__2].i = arf[i__3].i; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of CTFTTR */ + +} /* ctfttr_ */ + diff --git a/lapack-netlib/SRC/ctgevc.c b/lapack-netlib/SRC/ctgevc.c new file mode 100644 index 000000000..32de7979f --- /dev/null +++ b/lapack-netlib/SRC/ctgevc.c @@ -0,0 +1,1428 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGEVC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGEVC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, */ +/* LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* REAL RWORK( * ) */ +/* COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGEVC computes some or all of the right and/or left eigenvectors of */ +/* > a pair of complex matrices (S,P), where S and P are upper triangular. */ +/* > Matrix pairs of this type are produced by the generalized Schur */ +/* > factorization of a complex matrix pair (A,B): */ +/* > */ +/* > A = Q*S*Z**H, B = Q*P*Z**H */ +/* > */ +/* > as computed by CGGHRD + CHGEQZ. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of (S,P) */ +/* > corresponding to an eigenvalue w are defined by: */ +/* > */ +/* > S*x = w*P*x, (y**H)*S = w*(y**H)*P, */ +/* > */ +/* > where y**H denotes the conjugate tranpose of y. */ +/* > The eigenvalues are not input to this routine, but are computed */ +/* > directly from the diagonal elements of S and P. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of (S,P), or the products Z*X and/or Q*Y, */ +/* > where Z and Q are input matrices. */ +/* > If Q and Z are the unitary factors from the generalized Schur */ +/* > factorization of a matrix pair (A,B), then Z*X and Q*Y */ +/* > are the matrices of right and left eigenvectors of (A,B). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed by the matrices in VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > specified by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY='S', SELECT specifies the eigenvectors to be */ +/* > computed. The eigenvector corresponding to the j-th */ +/* > eigenvalue is computed if SELECT(j) = .TRUE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices S and P. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is COMPLEX array, dimension (LDS,N) */ +/* > The upper triangular matrix S from a generalized Schur */ +/* > factorization, as computed by CHGEQZ. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDS */ +/* > \verbatim */ +/* > LDS is INTEGER */ +/* > The leading dimension of array S. LDS >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is COMPLEX array, dimension (LDP,N) */ +/* > The upper triangular matrix P from a generalized Schur */ +/* > factorization, as computed by CHGEQZ. P must have real */ +/* > diagonal elements. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDP */ +/* > \verbatim */ +/* > LDP is INTEGER */ +/* > The leading dimension of array P. LDP >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the unitary matrix Q */ +/* > of left Schur vectors returned by CHGEQZ). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */ +/* > SELECT, stored consecutively in the columns of */ +/* > VL, in the same order as their eigenvalues. */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of array VL. LDVL >= 1, and if */ +/* > SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Q (usually the unitary matrix Z */ +/* > of right Schur vectors returned by CHGEQZ). */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */ +/* > if HOWMNY = 'B', the matrix Z*X; */ +/* > if HOWMNY = 'S', the right eigenvectors of (S,P) specified by */ +/* > SELECT, stored consecutively in the columns of */ +/* > VR, in the same order as their eigenvalues. */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1, and if */ +/* > SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ +/* > is set to N. Each selected eigenvector occupies one column. */ +/* > \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. */ +/* > < 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 complexGEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select, + integer *n, complex *s, integer *lds, complex *p, integer *ldp, + complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, + integer *m, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4, r__5, r__6; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer ibeg, ieig, iend; + real dmin__; + integer isrc; + real temp; + complex suma, sumb; + real xmax; + complex d__; + integer i__, j; + real scale; + logical ilall; + integer iside; + real sbeta; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + real small; + logical compl; + real anorm, bnorm; + logical compr; + complex ca, cb; + logical ilbbad; + real acoefa; + integer je; + real bcoefa, acoeff; + complex bcoeff; + logical ilback; + integer im; + extern /* Subroutine */ int slabad_(real *, real *); + real ascale, bscale; + integer jr; + extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); + extern real slamch_(char *); + complex salpha; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + logical ilcomp; + integer ihwmny; + real big; + logical lsa, lsb; + real ulp; + complex sum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters */ + + /* Parameter adjustments */ + --select; + s_dim1 = *lds; + s_offset = 1 + s_dim1 * 1; + s -= s_offset; + p_dim1 = *ldp; + p_offset = 1 + p_dim1 * 1; + p -= p_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --rwork; + + /* Function Body */ + if (lsame_(howmny, "A")) { + ihwmny = 1; + ilall = TRUE_; + ilback = FALSE_; + } else if (lsame_(howmny, "S")) { + ihwmny = 2; + ilall = FALSE_; + ilback = FALSE_; + } else if (lsame_(howmny, "B")) { + ihwmny = 3; + ilall = TRUE_; + ilback = TRUE_; + } else { + ihwmny = -1; + } + + if (lsame_(side, "R")) { + iside = 1; + compl = FALSE_; + compr = TRUE_; + } else if (lsame_(side, "L")) { + iside = 2; + compl = TRUE_; + compr = FALSE_; + } else if (lsame_(side, "B")) { + iside = 3; + compl = TRUE_; + compr = TRUE_; + } else { + iside = -1; + } + + *info = 0; + if (iside < 0) { + *info = -1; + } else if (ihwmny < 0) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lds < f2cmax(1,*n)) { + *info = -6; + } else if (*ldp < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGEVC", &i__1, (ftnlen)6); + return 0; + } + +/* Count the number of eigenvectors */ + + if (! ilall) { + im = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (select[j]) { + ++im; + } +/* L10: */ + } + } else { + im = *n; + } + +/* Check diagonal of B */ + + ilbbad = FALSE_; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (r_imag(&p[j + j * p_dim1]) != 0.f) { + ilbbad = TRUE_; + } +/* L20: */ + } + + if (ilbbad) { + *info = -7; + } else if (compl && *ldvl < *n || *ldvl < 1) { + *info = -10; + } else if (compr && *ldvr < *n || *ldvr < 1) { + *info = -12; + } else if (*mm < im) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGEVC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *m = im; + if (*n == 0) { + return 0; + } + +/* Machine Constants */ + + safmin = slamch_("Safe minimum"); + big = 1.f / safmin; + slabad_(&safmin, &big); + ulp = slamch_("Epsilon") * slamch_("Base"); + small = safmin * *n / ulp; + big = 1.f / small; + bignum = 1.f / (safmin * *n); + +/* Compute the 1-norm of each column of the strictly upper triangular */ +/* part of A and B to check for possible overflow in the triangular */ +/* solver. */ + + i__1 = s_dim1 + 1; + anorm = (r__1 = s[i__1].r, abs(r__1)) + (r__2 = r_imag(&s[s_dim1 + 1]), + abs(r__2)); + i__1 = p_dim1 + 1; + bnorm = (r__1 = p[i__1].r, abs(r__1)) + (r__2 = r_imag(&p[p_dim1 + 1]), + abs(r__2)); + rwork[1] = 0.f; + rwork[*n + 1] = 0.f; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + rwork[j] = 0.f; + rwork[*n + j] = 0.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * s_dim1; + rwork[j] += (r__1 = s[i__3].r, abs(r__1)) + (r__2 = r_imag(&s[i__ + + j * s_dim1]), abs(r__2)); + i__3 = i__ + j * p_dim1; + rwork[*n + j] += (r__1 = p[i__3].r, abs(r__1)) + (r__2 = r_imag(& + p[i__ + j * p_dim1]), abs(r__2)); +/* L30: */ + } +/* Computing MAX */ + i__2 = j + j * s_dim1; + r__3 = anorm, r__4 = rwork[j] + ((r__1 = s[i__2].r, abs(r__1)) + ( + r__2 = r_imag(&s[j + j * s_dim1]), abs(r__2))); + anorm = f2cmax(r__3,r__4); +/* Computing MAX */ + i__2 = j + j * p_dim1; + r__3 = bnorm, r__4 = rwork[*n + j] + ((r__1 = p[i__2].r, abs(r__1)) + + (r__2 = r_imag(&p[j + j * p_dim1]), abs(r__2))); + bnorm = f2cmax(r__3,r__4); +/* L40: */ + } + + ascale = 1.f / f2cmax(anorm,safmin); + bscale = 1.f / f2cmax(bnorm,safmin); + +/* Left eigenvectors */ + + if (compl) { + ieig = 0; + +/* Main loop over eigenvalues */ + + i__1 = *n; + for (je = 1; je <= i__1; ++je) { + if (ilall) { + ilcomp = TRUE_; + } else { + ilcomp = select[je]; + } + if (ilcomp) { + ++ieig; + + i__2 = je + je * s_dim1; + i__3 = je + je * p_dim1; + if ((r__2 = s[i__2].r, abs(r__2)) + (r__3 = r_imag(&s[je + je + * s_dim1]), abs(r__3)) <= safmin && (r__1 = p[i__3].r, + abs(r__1)) <= safmin) { + +/* Singular matrix pencil -- return unit eigenvector */ + + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + i__3 = jr + ieig * vl_dim1; + vl[i__3].r = 0.f, vl[i__3].i = 0.f; +/* L50: */ + } + i__2 = ieig + ieig * vl_dim1; + vl[i__2].r = 1.f, vl[i__2].i = 0.f; + goto L140; + } + +/* Non-singular eigenvalue: */ +/* Compute coefficients a and b in */ +/* H */ +/* y ( a A - b B ) = 0 */ + +/* Computing MAX */ + i__2 = je + je * s_dim1; + i__3 = je + je * p_dim1; + r__4 = ((r__2 = s[i__2].r, abs(r__2)) + (r__3 = r_imag(&s[je + + je * s_dim1]), abs(r__3))) * ascale, r__5 = (r__1 = + p[i__3].r, abs(r__1)) * bscale, r__4 = f2cmax(r__4,r__5); + temp = 1.f / f2cmax(r__4,safmin); + i__2 = je + je * s_dim1; + q__2.r = temp * s[i__2].r, q__2.i = temp * s[i__2].i; + q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i; + salpha.r = q__1.r, salpha.i = q__1.i; + i__2 = je + je * p_dim1; + sbeta = temp * p[i__2].r * bscale; + acoeff = sbeta * ascale; + q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i; + bcoeff.r = q__1.r, bcoeff.i = q__1.i; + +/* Scale to avoid underflow */ + + lsa = abs(sbeta) >= safmin && abs(acoeff) < small; + lsb = (r__1 = salpha.r, abs(r__1)) + (r__2 = r_imag(&salpha), + abs(r__2)) >= safmin && (r__3 = bcoeff.r, abs(r__3)) + + (r__4 = r_imag(&bcoeff), abs(r__4)) < small; + + scale = 1.f; + if (lsa) { + scale = small / abs(sbeta) * f2cmin(anorm,big); + } + if (lsb) { +/* Computing MAX */ + r__3 = scale, r__4 = small / ((r__1 = salpha.r, abs(r__1)) + + (r__2 = r_imag(&salpha), abs(r__2))) * f2cmin( + bnorm,big); + scale = f2cmax(r__3,r__4); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + r__5 = 1.f, r__6 = abs(acoeff), r__5 = f2cmax(r__5,r__6), + r__6 = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = + r_imag(&bcoeff), abs(r__2)); + r__3 = scale, r__4 = 1.f / (safmin * f2cmax(r__5,r__6)); + scale = f2cmin(r__3,r__4); + if (lsa) { + acoeff = ascale * (scale * sbeta); + } else { + acoeff = scale * acoeff; + } + if (lsb) { + q__2.r = scale * salpha.r, q__2.i = scale * salpha.i; + q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i; + bcoeff.r = q__1.r, bcoeff.i = q__1.i; + } else { + q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i; + bcoeff.r = q__1.r, bcoeff.i = q__1.i; + } + } + + acoefa = abs(acoeff); + bcoefa = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = r_imag(& + bcoeff), abs(r__2)); + xmax = 1.f; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + i__3 = jr; + work[i__3].r = 0.f, work[i__3].i = 0.f; +/* L60: */ + } + i__2 = je; + work[i__2].r = 1.f, work[i__2].i = 0.f; +/* Computing MAX */ + r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, + r__1 = f2cmax(r__1,r__2); + dmin__ = f2cmax(r__1,safmin); + +/* H */ +/* Triangular solve of (a A - b B) y = 0 */ + +/* H */ +/* (rowwise in (a A - b B) , or columnwise in a A - b B) */ + + i__2 = *n; + for (j = je + 1; j <= i__2; ++j) { + +/* Compute */ +/* j-1 */ +/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */ +/* k=je */ +/* (Scale if necessary) */ + + temp = 1.f / xmax; + if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum * + temp) { + i__3 = j - 1; + for (jr = je; jr <= i__3; ++jr) { + i__4 = jr; + i__5 = jr; + q__1.r = temp * work[i__5].r, q__1.i = temp * + work[i__5].i; + work[i__4].r = q__1.r, work[i__4].i = q__1.i; +/* L70: */ + } + xmax = 1.f; + } + suma.r = 0.f, suma.i = 0.f; + sumb.r = 0.f, sumb.i = 0.f; + + i__3 = j - 1; + for (jr = je; jr <= i__3; ++jr) { + r_cnjg(&q__3, &s[jr + j * s_dim1]); + i__4 = jr; + q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4] + .i, q__2.i = q__3.r * work[i__4].i + q__3.i * + work[i__4].r; + q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i; + suma.r = q__1.r, suma.i = q__1.i; + r_cnjg(&q__3, &p[jr + j * p_dim1]); + i__4 = jr; + q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4] + .i, q__2.i = q__3.r * work[i__4].i + q__3.i * + work[i__4].r; + q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i; + sumb.r = q__1.r, sumb.i = q__1.i; +/* L80: */ + } + q__2.r = acoeff * suma.r, q__2.i = acoeff * suma.i; + r_cnjg(&q__4, &bcoeff); + q__3.r = q__4.r * sumb.r - q__4.i * sumb.i, q__3.i = + q__4.r * sumb.i + q__4.i * sumb.r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + sum.r = q__1.r, sum.i = q__1.i; + +/* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) */ + +/* with scaling and perturbation of the denominator */ + + i__3 = j + j * s_dim1; + q__3.r = acoeff * s[i__3].r, q__3.i = acoeff * s[i__3].i; + i__4 = j + j * p_dim1; + q__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i, + q__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] + .r; + q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + r_cnjg(&q__1, &q__2); + d__.r = q__1.r, d__.i = q__1.i; + if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( + r__2)) <= dmin__) { + q__1.r = dmin__, q__1.i = 0.f; + d__.r = q__1.r, d__.i = q__1.i; + } + + if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( + r__2)) < 1.f) { + if ((r__1 = sum.r, abs(r__1)) + (r__2 = r_imag(&sum), + abs(r__2)) >= bignum * ((r__3 = d__.r, abs( + r__3)) + (r__4 = r_imag(&d__), abs(r__4)))) { + temp = 1.f / ((r__1 = sum.r, abs(r__1)) + (r__2 = + r_imag(&sum), abs(r__2))); + i__3 = j - 1; + for (jr = je; jr <= i__3; ++jr) { + i__4 = jr; + i__5 = jr; + q__1.r = temp * work[i__5].r, q__1.i = temp * + work[i__5].i; + work[i__4].r = q__1.r, work[i__4].i = q__1.i; +/* L90: */ + } + xmax = temp * xmax; + q__1.r = temp * sum.r, q__1.i = temp * sum.i; + sum.r = q__1.r, sum.i = q__1.i; + } + } + i__3 = j; + q__2.r = -sum.r, q__2.i = -sum.i; + cladiv_(&q__1, &q__2, &d__); + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* Computing MAX */ + i__3 = j; + r__3 = xmax, r__4 = (r__1 = work[i__3].r, abs(r__1)) + ( + r__2 = r_imag(&work[j]), abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L100: */ + } + +/* Back transform eigenvector if HOWMNY='B'. */ + + if (ilback) { + i__2 = *n + 1 - je; + cgemv_("N", n, &i__2, &c_b2, &vl[je * vl_dim1 + 1], ldvl, + &work[je], &c__1, &c_b1, &work[*n + 1], &c__1); + isrc = 2; + ibeg = 1; + } else { + isrc = 1; + ibeg = je; + } + +/* Copy and scale eigenvector into column of VL */ + + xmax = 0.f; + i__2 = *n; + for (jr = ibeg; jr <= i__2; ++jr) { +/* Computing MAX */ + i__3 = (isrc - 1) * *n + jr; + r__3 = xmax, r__4 = (r__1 = work[i__3].r, abs(r__1)) + ( + r__2 = r_imag(&work[(isrc - 1) * *n + jr]), abs( + r__2)); + xmax = f2cmax(r__3,r__4); +/* L110: */ + } + + if (xmax > safmin) { + temp = 1.f / xmax; + i__2 = *n; + for (jr = ibeg; jr <= i__2; ++jr) { + i__3 = jr + ieig * vl_dim1; + i__4 = (isrc - 1) * *n + jr; + q__1.r = temp * work[i__4].r, q__1.i = temp * work[ + i__4].i; + vl[i__3].r = q__1.r, vl[i__3].i = q__1.i; +/* L120: */ + } + } else { + ibeg = *n + 1; + } + + i__2 = ibeg - 1; + for (jr = 1; jr <= i__2; ++jr) { + i__3 = jr + ieig * vl_dim1; + vl[i__3].r = 0.f, vl[i__3].i = 0.f; +/* L130: */ + } + + } +L140: + ; + } + } + +/* Right eigenvectors */ + + if (compr) { + ieig = im + 1; + +/* Main loop over eigenvalues */ + + for (je = *n; je >= 1; --je) { + if (ilall) { + ilcomp = TRUE_; + } else { + ilcomp = select[je]; + } + if (ilcomp) { + --ieig; + + i__1 = je + je * s_dim1; + i__2 = je + je * p_dim1; + if ((r__2 = s[i__1].r, abs(r__2)) + (r__3 = r_imag(&s[je + je + * s_dim1]), abs(r__3)) <= safmin && (r__1 = p[i__2].r, + abs(r__1)) <= safmin) { + +/* Singular matrix pencil -- return unit eigenvector */ + + i__1 = *n; + for (jr = 1; jr <= i__1; ++jr) { + i__2 = jr + ieig * vr_dim1; + vr[i__2].r = 0.f, vr[i__2].i = 0.f; +/* L150: */ + } + i__1 = ieig + ieig * vr_dim1; + vr[i__1].r = 1.f, vr[i__1].i = 0.f; + goto L250; + } + +/* Non-singular eigenvalue: */ +/* Compute coefficients a and b in */ + +/* ( a A - b B ) x = 0 */ + +/* Computing MAX */ + i__1 = je + je * s_dim1; + i__2 = je + je * p_dim1; + r__4 = ((r__2 = s[i__1].r, abs(r__2)) + (r__3 = r_imag(&s[je + + je * s_dim1]), abs(r__3))) * ascale, r__5 = (r__1 = + p[i__2].r, abs(r__1)) * bscale, r__4 = f2cmax(r__4,r__5); + temp = 1.f / f2cmax(r__4,safmin); + i__1 = je + je * s_dim1; + q__2.r = temp * s[i__1].r, q__2.i = temp * s[i__1].i; + q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i; + salpha.r = q__1.r, salpha.i = q__1.i; + i__1 = je + je * p_dim1; + sbeta = temp * p[i__1].r * bscale; + acoeff = sbeta * ascale; + q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i; + bcoeff.r = q__1.r, bcoeff.i = q__1.i; + +/* Scale to avoid underflow */ + + lsa = abs(sbeta) >= safmin && abs(acoeff) < small; + lsb = (r__1 = salpha.r, abs(r__1)) + (r__2 = r_imag(&salpha), + abs(r__2)) >= safmin && (r__3 = bcoeff.r, abs(r__3)) + + (r__4 = r_imag(&bcoeff), abs(r__4)) < small; + + scale = 1.f; + if (lsa) { + scale = small / abs(sbeta) * f2cmin(anorm,big); + } + if (lsb) { +/* Computing MAX */ + r__3 = scale, r__4 = small / ((r__1 = salpha.r, abs(r__1)) + + (r__2 = r_imag(&salpha), abs(r__2))) * f2cmin( + bnorm,big); + scale = f2cmax(r__3,r__4); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + r__5 = 1.f, r__6 = abs(acoeff), r__5 = f2cmax(r__5,r__6), + r__6 = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = + r_imag(&bcoeff), abs(r__2)); + r__3 = scale, r__4 = 1.f / (safmin * f2cmax(r__5,r__6)); + scale = f2cmin(r__3,r__4); + if (lsa) { + acoeff = ascale * (scale * sbeta); + } else { + acoeff = scale * acoeff; + } + if (lsb) { + q__2.r = scale * salpha.r, q__2.i = scale * salpha.i; + q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i; + bcoeff.r = q__1.r, bcoeff.i = q__1.i; + } else { + q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i; + bcoeff.r = q__1.r, bcoeff.i = q__1.i; + } + } + + acoefa = abs(acoeff); + bcoefa = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = r_imag(& + bcoeff), abs(r__2)); + xmax = 1.f; + i__1 = *n; + for (jr = 1; jr <= i__1; ++jr) { + i__2 = jr; + work[i__2].r = 0.f, work[i__2].i = 0.f; +/* L160: */ + } + i__1 = je; + work[i__1].r = 1.f, work[i__1].i = 0.f; +/* Computing MAX */ + r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, + r__1 = f2cmax(r__1,r__2); + dmin__ = f2cmax(r__1,safmin); + +/* Triangular solve of (a A - b B) x = 0 (columnwise) */ + +/* WORK(1:j-1) contains sums w, */ +/* WORK(j+1:JE) contains x */ + + i__1 = je - 1; + for (jr = 1; jr <= i__1; ++jr) { + i__2 = jr; + i__3 = jr + je * s_dim1; + q__2.r = acoeff * s[i__3].r, q__2.i = acoeff * s[i__3].i; + i__4 = jr + je * p_dim1; + q__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i, + q__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] + .r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; +/* L170: */ + } + i__1 = je; + work[i__1].r = 1.f, work[i__1].i = 0.f; + + for (j = je - 1; j >= 1; --j) { + +/* Form x(j) := - w(j) / d */ +/* with scaling and perturbation of the denominator */ + + i__1 = j + j * s_dim1; + q__2.r = acoeff * s[i__1].r, q__2.i = acoeff * s[i__1].i; + i__2 = j + j * p_dim1; + q__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i, + q__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2] + .r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + d__.r = q__1.r, d__.i = q__1.i; + if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( + r__2)) <= dmin__) { + q__1.r = dmin__, q__1.i = 0.f; + d__.r = q__1.r, d__.i = q__1.i; + } + + if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( + r__2)) < 1.f) { + i__1 = j; + if ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag( + &work[j]), abs(r__2)) >= bignum * ((r__3 = + d__.r, abs(r__3)) + (r__4 = r_imag(&d__), abs( + r__4)))) { + i__1 = j; + temp = 1.f / ((r__1 = work[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&work[j]), abs(r__2))); + i__1 = je; + for (jr = 1; jr <= i__1; ++jr) { + i__2 = jr; + i__3 = jr; + q__1.r = temp * work[i__3].r, q__1.i = temp * + work[i__3].i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; +/* L180: */ + } + } + } + + i__1 = j; + i__2 = j; + q__2.r = -work[i__2].r, q__2.i = -work[i__2].i; + cladiv_(&q__1, &q__2, &d__); + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + + if (j > 1) { + +/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */ + + i__1 = j; + if ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag( + &work[j]), abs(r__2)) > 1.f) { + i__1 = j; + temp = 1.f / ((r__1 = work[i__1].r, abs(r__1)) + ( + r__2 = r_imag(&work[j]), abs(r__2))); + if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >= + bignum * temp) { + i__1 = je; + for (jr = 1; jr <= i__1; ++jr) { + i__2 = jr; + i__3 = jr; + q__1.r = temp * work[i__3].r, q__1.i = + temp * work[i__3].i; + work[i__2].r = q__1.r, work[i__2].i = + q__1.i; +/* L190: */ + } + } + } + + i__1 = j; + q__1.r = acoeff * work[i__1].r, q__1.i = acoeff * + work[i__1].i; + ca.r = q__1.r, ca.i = q__1.i; + i__1 = j; + q__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[ + i__1].i, q__1.i = bcoeff.r * work[i__1].i + + bcoeff.i * work[i__1].r; + cb.r = q__1.r, cb.i = q__1.i; + i__1 = j - 1; + for (jr = 1; jr <= i__1; ++jr) { + i__2 = jr; + i__3 = jr; + i__4 = jr + j * s_dim1; + q__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i, + q__3.i = ca.r * s[i__4].i + ca.i * s[i__4] + .r; + q__2.r = work[i__3].r + q__3.r, q__2.i = work[ + i__3].i + q__3.i; + i__5 = jr + j * p_dim1; + q__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i, + q__4.i = cb.r * p[i__5].i + cb.i * p[i__5] + .r; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; +/* L200: */ + } + } +/* L210: */ + } + +/* Back transform eigenvector if HOWMNY='B'. */ + + if (ilback) { + cgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1], + &c__1, &c_b1, &work[*n + 1], &c__1); + isrc = 2; + iend = *n; + } else { + isrc = 1; + iend = je; + } + +/* Copy and scale eigenvector into column of VR */ + + xmax = 0.f; + i__1 = iend; + for (jr = 1; jr <= i__1; ++jr) { +/* Computing MAX */ + i__2 = (isrc - 1) * *n + jr; + r__3 = xmax, r__4 = (r__1 = work[i__2].r, abs(r__1)) + ( + r__2 = r_imag(&work[(isrc - 1) * *n + jr]), abs( + r__2)); + xmax = f2cmax(r__3,r__4); +/* L220: */ + } + + if (xmax > safmin) { + temp = 1.f / xmax; + i__1 = iend; + for (jr = 1; jr <= i__1; ++jr) { + i__2 = jr + ieig * vr_dim1; + i__3 = (isrc - 1) * *n + jr; + q__1.r = temp * work[i__3].r, q__1.i = temp * work[ + i__3].i; + vr[i__2].r = q__1.r, vr[i__2].i = q__1.i; +/* L230: */ + } + } else { + iend = 0; + } + + i__1 = *n; + for (jr = iend + 1; jr <= i__1; ++jr) { + i__2 = jr + ieig * vr_dim1; + vr[i__2].r = 0.f, vr[i__2].i = 0.f; +/* L240: */ + } + + } +L250: + ; + } + } + + return 0; + +/* End of CTGEVC */ + +} /* ctgevc_ */ + diff --git a/lapack-netlib/SRC/ctgex2.c b/lapack-netlib/SRC/ctgex2.c new file mode 100644 index 000000000..675d52c2e --- /dev/null +++ b/lapack-netlib/SRC/ctgex2.c @@ -0,0 +1,828 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an unitary +equivalence transformation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGEX2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, */ +/* LDZ, J1, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N */ +/* COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) */ +/* > in an upper triangular matrix pair (A, B) by an unitary equivalence */ +/* > transformation. */ +/* > */ +/* > (A, B) must be in generalized Schur canonical form, that is, A and */ +/* > B are both upper triangular. */ +/* > */ +/* > Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* > updated. */ +/* > */ +/* > Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H */ +/* > Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the matrix A in the pair (A, B). */ +/* > On exit, the updated matrix A. */ +/* > \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,N) */ +/* > On entry, the matrix B in the pair (A, B). */ +/* > On exit, the updated 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] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, */ +/* > the updated matrix Q. */ +/* > Not referenced if WANTQ = .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1; */ +/* > If WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ,N) */ +/* > If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit, */ +/* > the updated matrix Z. */ +/* > Not referenced if WANTZ = .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1; */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The index to the first block (A11, B11). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit. */ +/* > =1: The transformed matrix pair (A, B) would be too far */ +/* > from generalized Schur form; the problem is ill- */ +/* > conditioned. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complexGEauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > In the current code both weak and strong stability tests are */ +/* > performed. The user can omit the strong stability test by changing */ +/* > the internal logical parameter WANDS to .FALSE.. See ref. [2] for */ +/* > details. */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > \n */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, Report UMINF-94.04, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, 1994. Also as LAPACK Working Note 87. To appear in */ +/* > Numerical Algorithms, 1996. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctgex2_(logical *wantq, logical *wantz, integer *n, + complex *a, integer *lda, complex *b, integer *ldb, complex *q, + integer *ldq, complex *z__, integer *ldz, integer *j1, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2, i__3; + real r__1; + complex q__1, q__2, q__3; + + /* Local variables */ + logical weak; + complex cdum; + extern /* Subroutine */ int crot_(integer *, complex *, integer *, + complex *, integer *, real *, complex *); + complex work[8], f, g; + integer i__, m; + complex s[4] /* was [2][2] */, t[4] /* was [2][2] */; + real scale, cq, sa, sb, cz; + complex sq; + real ss; + extern real slamch_(char *); + real ws; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), clartg_(complex *, + complex *, real *, complex *, complex *); + complex sz; + extern /* Subroutine */ int classq_(integer *, complex *, integer *, real + *, real *); + real thresh, smlnum; + logical strong; + real eps, sum; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + + m = 2; + weak = FALSE_; + strong = FALSE_; + +/* Make a local copy of selected block in (A, B) */ + + clacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__2); + clacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__2); + +/* Compute the threshold for testing the acceptance of swapping. */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + scale = 0.f; + sum = 1.f; + clacpy_("Full", &m, &m, s, &c__2, work, &m); + clacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m); + i__1 = (m << 1) * m; + classq_(&i__1, work, &c__1, &scale, &sum); + sa = scale * sqrt(sum); + +/* THRES has been changed from */ +/* THRESH = MAX( TEN*EPS*SA, SMLNUM ) */ +/* to */ +/* THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) */ +/* on 04/01/10. */ +/* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by */ +/* Jim Demmel and Guillaume Revy. See forum post 1783. */ + +/* Computing MAX */ + r__1 = eps * 20.f * sa; + thresh = f2cmax(r__1,smlnum); + +/* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks */ +/* using Givens rotations and perform the swap tentatively. */ + + q__2.r = s[3].r * t[0].r - s[3].i * t[0].i, q__2.i = s[3].r * t[0].i + s[ + 3].i * t[0].r; + q__3.r = t[3].r * s[0].r - t[3].i * s[0].i, q__3.i = t[3].r * s[0].i + t[ + 3].i * s[0].r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + f.r = q__1.r, f.i = q__1.i; + q__2.r = s[3].r * t[2].r - s[3].i * t[2].i, q__2.i = s[3].r * t[2].i + s[ + 3].i * t[2].r; + q__3.r = t[3].r * s[2].r - t[3].i * s[2].i, q__3.i = t[3].r * s[2].i + t[ + 3].i * s[2].r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + g.r = q__1.r, g.i = q__1.i; + sa = c_abs(&s[3]); + sb = c_abs(&t[3]); + clartg_(&g, &f, &cz, &sz, &cdum); + q__1.r = -sz.r, q__1.i = -sz.i; + sz.r = q__1.r, sz.i = q__1.i; + r_cnjg(&q__1, &sz); + crot_(&c__2, s, &c__1, &s[2], &c__1, &cz, &q__1); + r_cnjg(&q__1, &sz); + crot_(&c__2, t, &c__1, &t[2], &c__1, &cz, &q__1); + if (sa >= sb) { + clartg_(s, &s[1], &cq, &sq, &cdum); + } else { + clartg_(t, &t[1], &cq, &sq, &cdum); + } + crot_(&c__2, s, &c__2, &s[1], &c__2, &cq, &sq); + crot_(&c__2, t, &c__2, &t[1], &c__2, &cq, &sq); + +/* Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) */ + + ws = c_abs(&s[1]) + c_abs(&t[1]); + weak = ws <= thresh; + if (! weak) { + goto L20; + } + + if (TRUE_) { + +/* Strong stability test: */ +/* F-norm((A-QL**H*S*QR, B-QL**H*T*QR)) <= O(EPS*F-norm((A, B))) */ + + clacpy_("Full", &m, &m, s, &c__2, work, &m); + clacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m); + r_cnjg(&q__2, &sz); + q__1.r = -q__2.r, q__1.i = -q__2.i; + crot_(&c__2, work, &c__1, &work[2], &c__1, &cz, &q__1); + r_cnjg(&q__2, &sz); + q__1.r = -q__2.r, q__1.i = -q__2.i; + crot_(&c__2, &work[4], &c__1, &work[6], &c__1, &cz, &q__1); + q__1.r = -sq.r, q__1.i = -sq.i; + crot_(&c__2, work, &c__2, &work[1], &c__2, &cq, &q__1); + q__1.r = -sq.r, q__1.i = -sq.i; + crot_(&c__2, &work[4], &c__2, &work[5], &c__2, &cq, &q__1); + for (i__ = 1; i__ <= 2; ++i__) { + i__1 = i__ - 1; + i__2 = i__ - 1; + i__3 = *j1 + i__ - 1 + *j1 * a_dim1; + q__1.r = work[i__2].r - a[i__3].r, q__1.i = work[i__2].i - a[i__3] + .i; + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = i__ + 1; + i__2 = i__ + 1; + i__3 = *j1 + i__ - 1 + (*j1 + 1) * a_dim1; + q__1.r = work[i__2].r - a[i__3].r, q__1.i = work[i__2].i - a[i__3] + .i; + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = i__ + 3; + i__2 = i__ + 3; + i__3 = *j1 + i__ - 1 + *j1 * b_dim1; + q__1.r = work[i__2].r - b[i__3].r, q__1.i = work[i__2].i - b[i__3] + .i; + work[i__1].r = q__1.r, work[i__1].i = q__1.i; + i__1 = i__ + 5; + i__2 = i__ + 5; + i__3 = *j1 + i__ - 1 + (*j1 + 1) * b_dim1; + q__1.r = work[i__2].r - b[i__3].r, q__1.i = work[i__2].i - b[i__3] + .i; + work[i__1].r = q__1.r, work[i__1].i = q__1.i; +/* L10: */ + } + scale = 0.f; + sum = 1.f; + i__1 = (m << 1) * m; + classq_(&i__1, work, &c__1, &scale, &sum); + ss = scale * sqrt(sum); + strong = ss <= thresh; + if (! strong) { + goto L20; + } + } + +/* If the swap is accepted ("weakly" and "strongly"), apply the */ +/* equivalence transformations to the original matrix pair (A,B) */ + + i__1 = *j1 + 1; + r_cnjg(&q__1, &sz); + crot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], & + c__1, &cz, &q__1); + i__1 = *j1 + 1; + r_cnjg(&q__1, &sz); + crot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], & + c__1, &cz, &q__1); + i__1 = *n - *j1 + 1; + crot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], lda, + &cq, &sq); + i__1 = *n - *j1 + 1; + crot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], ldb, + &cq, &sq); + +/* Set N1 by N2 (2,1) blocks to 0 */ + + i__1 = *j1 + 1 + *j1 * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + i__1 = *j1 + 1 + *j1 * b_dim1; + b[i__1].r = 0.f, b[i__1].i = 0.f; + +/* Accumulate transformations into Q and Z if requested. */ + + if (*wantz) { + r_cnjg(&q__1, &sz); + crot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + 1], + &c__1, &cz, &q__1); + } + if (*wantq) { + r_cnjg(&q__1, &sq); + crot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], & + c__1, &cq, &q__1); + } + +/* Exit with INFO = 0 if swap was successfully performed. */ + + return 0; + +/* Exit with INFO = 1 if swap was rejected. */ + +L20: + *info = 1; + return 0; + +/* End of CTGEX2 */ + +} /* ctgex2_ */ + diff --git a/lapack-netlib/SRC/ctgexc.c b/lapack-netlib/SRC/ctgexc.c new file mode 100644 index 000000000..c00a82547 --- /dev/null +++ b/lapack-netlib/SRC/ctgexc.c @@ -0,0 +1,704 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGEXC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGEXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, */ +/* LDZ, IFST, ILST, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N */ +/* COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGEXC reorders the generalized Schur decomposition of a complex */ +/* > matrix pair (A,B), using an unitary equivalence transformation */ +/* > (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with */ +/* > row index IFST is moved to row ILST. */ +/* > */ +/* > (A, B) must be in generalized Schur canonical form, that is, A and */ +/* > B are both upper triangular. */ +/* > */ +/* > Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* > updated. */ +/* > */ +/* > Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H */ +/* > Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the upper triangular matrix A in the pair (A, B). */ +/* > On exit, the updated matrix A. */ +/* > \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,N) */ +/* > On entry, the upper triangular matrix B in the pair (A, B). */ +/* > On exit, the updated 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] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., the unitary matrix Q. */ +/* > On exit, the updated matrix Q. */ +/* > If WANTQ = .FALSE., Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1; */ +/* > If WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ,N) */ +/* > On entry, if WANTZ = .TRUE., the unitary matrix Z. */ +/* > On exit, the updated matrix Z. */ +/* > If WANTZ = .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1; */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IFST */ +/* > \verbatim */ +/* > IFST is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ILST */ +/* > \verbatim */ +/* > ILST is INTEGER */ +/* > Specify the reordering of the diagonal blocks of (A, B). */ +/* > The block with row index IFST is moved to row ILST, by a */ +/* > sequence of swapping between adjacent blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit. */ +/* > <0: if INFO = -i, the i-th argument had an illegal value. */ +/* > =1: The transformed matrix pair (A, B) would be too far */ +/* > from generalized Schur form; the problem is ill- */ +/* > conditioned. (A, B) may have been partially reordered, */ +/* > and ILST points to the first row of the current */ +/* > position of the block being moved. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complexGEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > \n */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, Report */ +/* > UMINF - 94.04, Department of Computing Science, Umea University, */ +/* > S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */ +/* > To appear in Numerical Algorithms, 1996. */ +/* > \n */ +/* > [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */ +/* > 1996. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctgexc_(logical *wantq, logical *wantz, integer *n, + complex *a, integer *lda, complex *b, integer *ldb, complex *q, + integer *ldq, complex *z__, integer *ldz, integer *ifst, integer * + ilst, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1; + + /* Local variables */ + integer here; + extern /* Subroutine */ int ctgex2_(logical *, logical *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Decode and test input arguments. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldq < 1 || *wantq && *ldq < f2cmax(1,*n)) { + *info = -9; + } else if (*ldz < 1 || *wantz && *ldz < f2cmax(1,*n)) { + *info = -11; + } else if (*ifst < 1 || *ifst > *n) { + *info = -12; + } else if (*ilst < 1 || *ilst > *n) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGEXC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + if (*ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + + here = *ifst; + +L10: + +/* Swap with next one below */ + + ctgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &here, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + if (here < *ilst) { + goto L10; + } + --here; + } else { + here = *ifst - 1; + +L20: + +/* Swap with next one above */ + + ctgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &here, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + if (here >= *ilst) { + goto L20; + } + ++here; + } + *ilst = here; + return 0; + +/* End of CTGEXC */ + +} /* ctgexc_ */ + diff --git a/lapack-netlib/SRC/ctgsen.c b/lapack-netlib/SRC/ctgsen.c new file mode 100644 index 000000000..5b8b2c9e3 --- /dev/null +++ b/lapack-netlib/SRC/ctgsen.c @@ -0,0 +1,1255 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGSEN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGSEN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, */ +/* ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, */ +/* WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, */ +/* $ M, N */ +/* REAL PL, PR */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* REAL DIF( * ) */ +/* COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGSEN reorders the generalized Schur decomposition of a complex */ +/* > matrix pair (A, B) (in terms of an unitary equivalence trans- */ +/* > formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues */ +/* > appears in the leading diagonal blocks of the pair (A,B). The leading */ +/* > columns of Q and Z form unitary bases of the corresponding left and */ +/* > right eigenspaces (deflating subspaces). (A, B) must be in */ +/* > generalized Schur canonical form, that is, A and B are both upper */ +/* > triangular. */ +/* > */ +/* > CTGSEN also computes the generalized eigenvalues */ +/* > */ +/* > w(j)= ALPHA(j) / BETA(j) */ +/* > */ +/* > of the reordered matrix pair (A, B). */ +/* > */ +/* > Optionally, the routine computes estimates of reciprocal condition */ +/* > numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */ +/* > (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */ +/* > between the matrix pairs (A11, B11) and (A22,B22) that correspond to */ +/* > the selected cluster and the eigenvalues outside the cluster, resp., */ +/* > and norms of "projections" onto left and right eigenspaces w.r.t. */ +/* > the selected cluster in the (1,1)-block. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies whether condition numbers are required for the */ +/* > cluster of eigenvalues (PL and PR) or the deflating subspaces */ +/* > (Difu and Difl): */ +/* > =0: Only reorder w.r.t. SELECT. No extras. */ +/* > =1: Reciprocal of norms of "projections" onto left and right */ +/* > eigenspaces w.r.t. the selected cluster (PL and PR). */ +/* > =2: Upper bounds on Difu and Difl. F-norm-based estimate */ +/* > (DIF(1:2)). */ +/* > =3: Estimate of Difu and Difl. 1-norm-based estimate */ +/* > (DIF(1:2)). */ +/* > About 5 times as expensive as IJOB = 2. */ +/* > =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */ +/* > version to get it all. */ +/* > =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > SELECT specifies the eigenvalues in the selected cluster. To */ +/* > select an eigenvalue w(j), SELECT(j) must be set to */ +/* > .TRUE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension(LDA,N) */ +/* > On entry, the upper triangular matrix A, in generalized */ +/* > Schur canonical form. */ +/* > On exit, A is overwritten by the reordered matrix A. */ +/* > \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,N) */ +/* > On entry, the upper triangular matrix B, in generalized */ +/* > Schur canonical form. */ +/* > On exit, B is overwritten by the reordered matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX array, dimension (N) */ +/* > */ +/* > The diagonal elements of A and B, respectively, */ +/* > when the pair (A,B) has been reduced to generalized Schur */ +/* > form. ALPHA(i)/BETA(i) i=1,...,N are the generalized */ +/* > eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */ +/* > On exit, Q has been postmultiplied by the left unitary */ +/* > transformation matrix which reorder (A, B); The leading M */ +/* > columns of Q form orthonormal bases for the specified pair of */ +/* > left eigenspaces (deflating subspaces). */ +/* > If WANTQ = .FALSE., Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1. */ +/* > If WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX array, dimension (LDZ,N) */ +/* > On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */ +/* > On exit, Z has been postmultiplied by the left unitary */ +/* > transformation matrix which reorder (A, B); The leading M */ +/* > columns of Z form orthonormal bases for the specified pair of */ +/* > left eigenspaces (deflating subspaces). */ +/* > If WANTZ = .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the specified pair of left and right */ +/* > eigenspaces, (deflating subspaces) 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PL */ +/* > \verbatim */ +/* > PL is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PR */ +/* > \verbatim */ +/* > PR is REAL */ +/* > */ +/* > If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */ +/* > reciprocal of the norm of "projections" onto left and right */ +/* > eigenspace with respect to the selected cluster. */ +/* > 0 < PL, PR <= 1. */ +/* > If M = 0 or M = N, PL = PR = 1. */ +/* > If IJOB = 0, 2 or 3 PL, PR are not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL array, dimension (2). */ +/* > If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */ +/* > If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */ +/* > Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */ +/* > estimates of Difu and Difl, computed using reversed */ +/* > communication with CLACN2. */ +/* > If M = 0 or N, DIF(1:2) = F-norm([A, B]). */ +/* > If IJOB = 0 or 1, DIF is not referenced. */ +/* > \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. LWORK >= 1 */ +/* > If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) */ +/* > If IJOB = 3 or 5, LWORK >= 4*M*(N-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] 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. LIWORK >= 1. */ +/* > If IJOB = 1, 2 or 4, LIWORK >= N+2; */ +/* > If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit. */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > =1: Reordering of (A, B) failed because the transformed */ +/* > matrix pair (A, B) would be too far from generalized */ +/* > Schur form; the problem is very ill-conditioned. */ +/* > (A, B) may have been partially reordered. */ +/* > If requested, 0 is returned in DIF(*), PL and PR. */ +/* > \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 Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGSEN first collects the selected eigenvalues by computing unitary */ +/* > U and W that move them to the top left corner of (A, B). In other */ +/* > words, the selected eigenvalues are the eigenvalues of (A11, B11) in */ +/* > */ +/* > U**H*(A, B)*W = (A11 A12) (B11 B12) n1 */ +/* > ( 0 A22),( 0 B22) n2 */ +/* > n1 n2 n1 n2 */ +/* > */ +/* > where N = n1+n2 and U**H means the conjugate transpose of U. The first */ +/* > n1 columns of U and W span the specified pair of left and right */ +/* > eigenspaces (deflating subspaces) of (A, B). */ +/* > */ +/* > If (A, B) has been obtained from the generalized real Schur */ +/* > decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */ +/* > reordered generalized Schur form of (C, D) is given by */ +/* > */ +/* > (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H, */ +/* > */ +/* > and the first n1 columns of Q*U and Z*W span the corresponding */ +/* > deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */ +/* > */ +/* > Note that if the selected eigenvalue is sufficiently ill-conditioned, */ +/* > then its value may differ significantly from its value before */ +/* > reordering. */ +/* > */ +/* > The reciprocal condition numbers of the left and right eigenspaces */ +/* > spanned by the first n1 columns of U and W (or Q*U and Z*W) may */ +/* > be returned in DIF(1:2), corresponding to Difu and Difl, resp. */ +/* > */ +/* > The Difu and Difl are defined as: */ +/* > */ +/* > Difu[(A11, B11), (A22, B22)] = sigma-f2cmin( Zu ) */ +/* > and */ +/* > Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */ +/* > */ +/* > where sigma-f2cmin(Zu) is the smallest singular value of the */ +/* > (2*n1*n2)-by-(2*n1*n2) matrix */ +/* > */ +/* > Zu = [ kron(In2, A11) -kron(A22**H, In1) ] */ +/* > [ kron(In2, B11) -kron(B22**H, In1) ]. */ +/* > */ +/* > Here, Inx is the identity matrix of size nx and A22**H is the */ +/* > conjuguate transpose of A22. kron(X, Y) is the Kronecker product between */ +/* > the matrices X and Y. */ +/* > */ +/* > When DIF(2) is small, small changes in (A, B) can cause large changes */ +/* > in the deflating subspace. An approximate (asymptotic) bound on the */ +/* > maximum angular error in the computed deflating subspaces is */ +/* > */ +/* > EPS * norm((A, B)) / DIF(2), */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal norm of the projectors on the left and right */ +/* > eigenspaces associated with (A11, B11) may be returned in PL and PR. */ +/* > They are computed as follows. First we compute L and R so that */ +/* > P*(A, B)*Q is block diagonal, where */ +/* > */ +/* > P = ( I -L ) n1 Q = ( I R ) n1 */ +/* > ( 0 I ) n2 and ( 0 I ) n2 */ +/* > n1 n2 n1 n2 */ +/* > */ +/* > and (L, R) is the solution to the generalized Sylvester equation */ +/* > */ +/* > A11*R - L*A22 = -A12 */ +/* > B11*R - L*B22 = -B12 */ +/* > */ +/* > Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */ +/* > An approximate (asymptotic) bound on the average absolute error of */ +/* > the selected eigenvalues is */ +/* > */ +/* > EPS * norm((A, B)) / PL. */ +/* > */ +/* > There are also global error bounds which valid for perturbations up */ +/* > to a certain restriction: A lower bound (x) on the smallest */ +/* > F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */ +/* > coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */ +/* > (i.e. (A + E, B + F), is */ +/* > */ +/* > x = f2cmin(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*f2cmax(1/PL,1/PR)). */ +/* > */ +/* > An approximate bound on x can be computed from DIF(1:2), PL and PR. */ +/* > */ +/* > If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */ +/* > (L', R') and unperturbed (L, R) left and right deflating subspaces */ +/* > associated with the selected cluster in the (1,1)-blocks can be */ +/* > bounded as */ +/* > */ +/* > f2cmax-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */ +/* > f2cmax-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */ +/* > */ +/* > See LAPACK User's Guide section 4.11 or the following references */ +/* > for more information. */ +/* > */ +/* > Note that if the default method for computing the Frobenius-norm- */ +/* > based estimate DIF is not wanted (see CLATDF), then the parameter */ +/* > IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF */ +/* > (IJOB = 2 will be used)). See CTGSYL for more details. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > \n */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, Report */ +/* > UMINF - 94.04, Department of Computing Science, Umea University, */ +/* > S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */ +/* > To appear in Numerical Algorithms, 1996. */ +/* > \n */ +/* > [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */ +/* > 1996. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz, + logical *select, integer *n, complex *a, integer *lda, complex *b, + integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq, + complex *z__, integer *ldz, integer *m, real *pl, real *pr, real * + dif, complex *work, integer *lwork, integer *iwork, integer *liwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2, i__3; + complex q__1, q__2; + + /* Local variables */ + integer kase, ierr; + real dsum; + logical swap; + complex temp1, temp2; + integer i__, k; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + integer isave[3]; + logical wantd; + integer lwmin; + logical wantp; + integer n1, n2; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + logical wantd1, wantd2; + real dscale; + integer ks; + extern real slamch_(char *); + real rdscal; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *); + real safmin; + extern /* Subroutine */ int ctgexc_(logical *, logical *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, integer *, integer *, integer *), xerbla_( + char *, integer *, ftnlen), classq_(integer *, complex *, integer + *, real *, real *); + integer liwmin; + extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer + *, complex *, integer *, complex *, integer *, complex *, integer + *, complex *, integer *, complex *, integer *, complex *, integer + *, real *, real *, complex *, integer *, integer *, integer *); + integer mn2; + logical lquery; + integer ijb; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --dif; + --work; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (*ijob < 0 || *ijob > 5) { + *info = -1; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldq < 1 || *wantq && *ldq < *n) { + *info = -13; + } else if (*ldz < 1 || *wantz && *ldz < *n) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGSEN", &i__1, (ftnlen)6); + return 0; + } + + ierr = 0; + + wantp = *ijob == 1 || *ijob >= 4; + wantd1 = *ijob == 2 || *ijob == 4; + wantd2 = *ijob == 3 || *ijob == 5; + wantd = wantd1 || wantd2; + +/* Set M to the dimension of the specified pair of deflating */ +/* subspaces. */ + + *m = 0; + if (! lquery || *ijob != 0) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k; + i__3 = k + k * a_dim1; + alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i; + i__2 = k; + i__3 = k + k * b_dim1; + beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i; + if (k < *n) { + if (select[k]) { + ++(*m); + } + } else { + if (select[*n]) { + ++(*m); + } + } +/* L10: */ + } + } + + if (*ijob == 1 || *ijob == 2 || *ijob == 4) { +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * (*n - *m); + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n + 2; + liwmin = f2cmax(i__1,i__2); + } else if (*ijob == 3 || *ijob == 5) { +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 2) * (*n - *m); + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = f2cmax(i__1,i__2), i__2 = + *n + 2; + liwmin = f2cmax(i__1,i__2); + } else { + lwmin = 1; + liwmin = 1; + } + + work[1].r = (real) lwmin, work[1].i = 0.f; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -21; + } else if (*liwork < liwmin && ! lquery) { + *info = -23; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGSEN", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == *n || *m == 0) { + if (wantp) { + *pl = 1.f; + *pr = 1.f; + } + if (wantd) { + dscale = 0.f; + dsum = 1.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + classq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum); + classq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum); +/* L20: */ + } + dif[1] = dscale * sqrt(dsum); + dif[2] = dif[1]; + } + goto L70; + } + +/* Get machine constant */ + + safmin = slamch_("S"); + +/* Collect the selected blocks at the top-left corner of (A, B). */ + + ks = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + swap = select[k]; + if (swap) { + ++ks; + +/* Swap the K-th block to position KS. Compute unitary Q */ +/* and Z that will swap adjacent diagonal blocks in (A, B). */ + + if (k != ks) { + ctgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, + &q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, & + ierr); + } + + if (ierr > 0) { + +/* Swap is rejected: exit. */ + + *info = 1; + if (wantp) { + *pl = 0.f; + *pr = 0.f; + } + if (wantd) { + dif[1] = 0.f; + dif[2] = 0.f; + } + goto L70; + } + } +/* L30: */ + } + if (wantp) { + +/* Solve generalized Sylvester equation for R and L: */ +/* A11 * R - L * A22 = A12 */ +/* B11 * R - L * B22 = B12 */ + + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + clacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1); + clacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 + + 1], &n1); + ijb = 0; + i__1 = *lwork - (n1 << 1) * n2; + ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1] + , lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ * + b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], & + work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); + +/* Estimate the reciprocal of norms of "projections" onto */ +/* left and right eigenspaces */ + + rdscal = 0.f; + dsum = 1.f; + i__1 = n1 * n2; + classq_(&i__1, &work[1], &c__1, &rdscal, &dsum); + *pl = rdscal * sqrt(dsum); + if (*pl == 0.f) { + *pl = 1.f; + } else { + *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl)); + } + rdscal = 0.f; + dsum = 1.f; + i__1 = n1 * n2; + classq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum); + *pr = rdscal * sqrt(dsum); + if (*pr == 0.f) { + *pr = 1.f; + } else { + *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr)); + } + } + if (wantd) { + +/* Compute estimates Difu and Difl. */ + + if (wantd1) { + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 3; + +/* Frobenius norm-based Difu estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * + a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + + i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, & + dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], & + ierr); + +/* Frobenius norm-based Difl estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + ctgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[ + a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1], + ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale, + &dif[2], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], & + ierr); + } else { + +/* Compute 1-norm-based estimates of Difu and Difl using */ +/* reversed communication with CLACN2. In each step a */ +/* generalized Sylvester equation or a transposed variant */ +/* is solved. */ + + kase = 0; + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 0; + mn2 = (n1 << 1) * n2; + +/* 1-norm-based estimate of Difu. */ + +L40: + clacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation */ + + i__1 = *lwork - (n1 << 1) * n2; + ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + ctgsyl_("C", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) + + 1], &i__1, &iwork[1], &ierr); + } + goto L40; + } + dif[1] = dscale / dif[1]; + +/* 1-norm-based estimate of Difl. */ + +L50: + clacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation */ + + i__1 = *lwork - (n1 << 1) * n2; + ctgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * + b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + ctgsyl_("C", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) + + 1], &i__1, &iwork[1], &ierr); + } + goto L50; + } + dif[2] = dscale / dif[2]; + } + } + +/* If B(K,K) is complex, make it real and positive (normalization */ +/* of the generalized Schur form) and Store the generalized */ +/* eigenvalues of reordered pair (A, B) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + dscale = c_abs(&b[k + k * b_dim1]); + if (dscale > safmin) { + i__2 = k + k * b_dim1; + q__2.r = b[i__2].r / dscale, q__2.i = b[i__2].i / dscale; + r_cnjg(&q__1, &q__2); + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = k + k * b_dim1; + q__1.r = b[i__2].r / dscale, q__1.i = b[i__2].i / dscale; + temp2.r = q__1.r, temp2.i = q__1.i; + i__2 = k + k * b_dim1; + b[i__2].r = dscale, b[i__2].i = 0.f; + i__2 = *n - k; + cscal_(&i__2, &temp1, &b[k + (k + 1) * b_dim1], ldb); + i__2 = *n - k + 1; + cscal_(&i__2, &temp1, &a[k + k * a_dim1], lda); + if (*wantq) { + cscal_(n, &temp2, &q[k * q_dim1 + 1], &c__1); + } + } else { + i__2 = k + k * b_dim1; + b[i__2].r = 0.f, b[i__2].i = 0.f; + } + + i__2 = k; + i__3 = k + k * a_dim1; + alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i; + i__2 = k; + i__3 = k + k * b_dim1; + beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i; + +/* L60: */ + } + +L70: + + work[1].r = (real) lwmin, work[1].i = 0.f; + iwork[1] = liwmin; + + return 0; + +/* End of CTGSEN */ + +} /* ctgsen_ */ + diff --git a/lapack-netlib/SRC/ctgsja.c b/lapack-netlib/SRC/ctgsja.c new file mode 100644 index 000000000..89cafe3e6 --- /dev/null +++ b/lapack-netlib/SRC/ctgsja.c @@ -0,0 +1,1168 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGSJA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGSJA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, */ +/* LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, */ +/* Q, LDQ, WORK, NCALL MYCYCLE, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, */ +/* $ NCALL MYCYCLE, P */ +/* REAL TOLA, TOLB */ +/* REAL ALPHA( * ), BETA( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGSJA computes the generalized singular value decomposition (GSVD) */ +/* > of two complex upper triangular (or trapezoidal) matrices A and B. */ +/* > */ +/* > On entry, it is assumed that matrices A and B have the following */ +/* > forms, which may be obtained by the preprocessing subroutine CGGSVP */ +/* > from a general M-by-N matrix A and P-by-N matrix B: */ +/* > */ +/* > N-K-L K L */ +/* > A = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > A = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > B = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. */ +/* > */ +/* > On exit, */ +/* > */ +/* > U**H *A*Q = D1*( 0 R ), V**H *B*Q = D2*( 0 R ), */ +/* > */ +/* > where U, V and Q are unitary matrices. */ +/* > R is a nonsingular upper triangular matrix, and D1 */ +/* > and D2 are ``diagonal'' matrices, which are of the following */ +/* > structures: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) K */ +/* > L ( 0 0 R22 ) L */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The computation of the unitary transformation matrices U, V or Q */ +/* > is optional. These matrices may either be formed explicitly, or they */ +/* > may be postmultiplied into input matrices U1, V1, or Q1. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': U must contain a unitary matrix U1 on entry, and */ +/* > the product U1*U is returned; */ +/* > = 'I': U is initialized to the unit matrix, and the */ +/* > unitary matrix U is returned; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': V must contain a unitary matrix V1 on entry, and */ +/* > the product V1*V is returned; */ +/* > = 'I': V is initialized to the unit matrix, and the */ +/* > unitary matrix V is returned; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Q must contain a unitary matrix Q1 on entry, and */ +/* > the product Q1*Q is returned; */ +/* > = 'I': Q is initialized to the unit matrix, and the */ +/* > unitary matrix Q is returned; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > K and L specify the subblocks in the input matrices A and B: */ +/* > A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N) */ +/* > of A and B, whose GSVD is going to be computed by CTGSJA. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */ +/* > matrix R or part of R. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */ +/* > a part of R. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is REAL */ +/* > */ +/* > TOLA and TOLB are the convergence criteria for the Jacobi- */ +/* > Kogbetliantz iteration procedure. Generally, they are the */ +/* > same as used in the preprocessing step, say */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = diag(C), */ +/* > BETA(K+1:K+L) = diag(S), */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */ +/* > BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */ +/* > Furthermore, if K+L < N, */ +/* > ALPHA(K+L+1:N) = 0 */ +/* > BETA(K+L+1:N) = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is COMPLEX array, dimension (LDU,M) */ +/* > On entry, if JOBU = 'U', U must contain a matrix U1 (usually */ +/* > the unitary matrix returned by CGGSVP). */ +/* > On exit, */ +/* > if JOBU = 'I', U contains the unitary matrix U; */ +/* > if JOBU = 'U', U contains the product U1*U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is COMPLEX array, dimension (LDV,P) */ +/* > On entry, if JOBV = 'V', V must contain a matrix V1 (usually */ +/* > the unitary matrix returned by CGGSVP). */ +/* > On exit, */ +/* > if JOBV = 'I', V contains the unitary matrix V; */ +/* > if JOBV = 'V', V contains the product V1*V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */ +/* > the unitary matrix returned by CGGSVP). */ +/* > On exit, */ +/* > if JOBQ = 'I', Q contains the unitary matrix Q; */ +/* > if JOBQ = 'Q', Q contains the product Q1*Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NCALL MYCYCLE */ +/* > \verbatim */ +/* > NCALL MYCYCLE is INTEGER */ +/* > The number of cycles required for convergence. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1: the procedure does not converge after MAXIT cycles. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > MAXIT INTEGER */ +/* > MAXIT specifies the total loops that the iterative procedure */ +/* > may take. If after MAXIT cycles, the routine fails to */ +/* > converge, we return INFO = 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 Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */ +/* > f2cmin(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */ +/* > matrix B13 to the form: */ +/* > */ +/* > U1**H *A13*Q1 = C1*R1; V1**H *B13*Q1 = S1*R1, */ +/* > */ +/* > where U1, V1 and Q1 are unitary matrix. */ +/* > C1 and S1 are diagonal matrices satisfying */ +/* > */ +/* > C1**2 + S1**2 = I, */ +/* > */ +/* > and R1 is an L-by-L nonsingular upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctgsja_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, integer *k, integer *l, complex *a, integer * + lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha, + real *beta, complex *u, integer *ldu, complex *v, integer *ldv, + complex *q, integer *ldq, complex *work, integer *ncallmycycle, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; + real r__1; + complex q__1; + + /* Local variables */ + extern /* Subroutine */ int crot_(integer *, complex *, integer *, + complex *, integer *, real *, complex *); + integer kcallmycycle, i__, j; + real gamma; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + logical initq; + real a1, a3, b1; + logical initu, initv, wantq, upper; + real b3, error; + logical wantu, wantv; + real ssmin; + complex a2, b2; + extern /* Subroutine */ int clags2_(logical *, real *, complex *, real *, + real *, complex *, real *, real *, complex *, real *, complex *, + real *, complex *), clapll_(integer *, complex *, integer *, + complex *, integer *, real *), csscal_(integer *, real *, complex + *, integer *), claset_(char *, integer *, integer *, complex *, + complex *, complex *, integer *), xerbla_(char *, integer + *, ftnlen), slartg_(real *, real *, real *, real *, real *); +// extern integer myhuge_(real *); + real csq, csu, csv; + complex snq; + real rwk; + complex snu, snv; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + initu = lsame_(jobu, "I"); + wantu = initu || lsame_(jobu, "U"); + + initv = lsame_(jobv, "I"); + wantv = initv || lsame_(jobv, "V"); + + initq = lsame_(jobq, "I"); + wantq = initq || lsame_(jobq, "Q"); + + *info = 0; + if (! (initu || wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (initv || wantv || lsame_(jobv, "N"))) + { + *info = -2; + } else if (! (initq || wantq || lsame_(jobq, "N"))) + { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -18; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -20; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -22; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGSJA", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize U, V and Q, if necessary */ + + if (initu) { + claset_("Full", m, m, &c_b1, &c_b2, &u[u_offset], ldu); + } + if (initv) { + claset_("Full", p, p, &c_b1, &c_b2, &v[v_offset], ldv); + } + if (initq) { + claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); + } + +/* Loop until convergence */ + + upper = FALSE_; + for (kcallmycycle = 1; kcallmycycle <= 40; ++kcallmycycle) { + + upper = ! upper; + + i__1 = *l - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l; + for (j = i__ + 1; j <= i__2; ++j) { + + a1 = 0.f; + a2.r = 0.f, a2.i = 0.f; + a3 = 0.f; + if (*k + i__ <= *m) { + i__3 = *k + i__ + (*n - *l + i__) * a_dim1; + a1 = a[i__3].r; + } + if (*k + j <= *m) { + i__3 = *k + j + (*n - *l + j) * a_dim1; + a3 = a[i__3].r; + } + + i__3 = i__ + (*n - *l + i__) * b_dim1; + b1 = b[i__3].r; + i__3 = j + (*n - *l + j) * b_dim1; + b3 = b[i__3].r; + + if (upper) { + if (*k + i__ <= *m) { + i__3 = *k + i__ + (*n - *l + j) * a_dim1; + a2.r = a[i__3].r, a2.i = a[i__3].i; + } + i__3 = i__ + (*n - *l + j) * b_dim1; + b2.r = b[i__3].r, b2.i = b[i__3].i; + } else { + if (*k + j <= *m) { + i__3 = *k + j + (*n - *l + i__) * a_dim1; + a2.r = a[i__3].r, a2.i = a[i__3].i; + } + i__3 = j + (*n - *l + i__) * b_dim1; + b2.r = b[i__3].r, b2.i = b[i__3].i; + } + + clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, & + csv, &snv, &csq, &snq); + +/* Update (K+I)-th and (K+J)-th rows of matrix A: U**H *A */ + + if (*k + j <= *m) { + r_cnjg(&q__1, &snu); + crot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k + + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &q__1) + ; + } + +/* Update I-th and J-th rows of matrix B: V**H *B */ + + r_cnjg(&q__1, &snv); + crot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - * + l + 1) * b_dim1], ldb, &csv, &q__1); + +/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */ +/* A and B: A*Q and B*Q */ + +/* Computing MIN */ + i__4 = *k + *l; + i__3 = f2cmin(i__4,*m); + crot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - * + l + i__) * a_dim1 + 1], &c__1, &csq, &snq); + + crot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l + + i__) * b_dim1 + 1], &c__1, &csq, &snq); + + if (upper) { + if (*k + i__ <= *m) { + i__3 = *k + i__ + (*n - *l + j) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } + i__3 = i__ + (*n - *l + j) * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; + } else { + if (*k + j <= *m) { + i__3 = *k + j + (*n - *l + i__) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } + i__3 = j + (*n - *l + i__) * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; + } + +/* Ensure that the diagonal elements of A and B are real. */ + + if (*k + i__ <= *m) { + i__3 = *k + i__ + (*n - *l + i__) * a_dim1; + i__4 = *k + i__ + (*n - *l + i__) * a_dim1; + r__1 = a[i__4].r; + a[i__3].r = r__1, a[i__3].i = 0.f; + } + if (*k + j <= *m) { + i__3 = *k + j + (*n - *l + j) * a_dim1; + i__4 = *k + j + (*n - *l + j) * a_dim1; + r__1 = a[i__4].r; + a[i__3].r = r__1, a[i__3].i = 0.f; + } + i__3 = i__ + (*n - *l + i__) * b_dim1; + i__4 = i__ + (*n - *l + i__) * b_dim1; + r__1 = b[i__4].r; + b[i__3].r = r__1, b[i__3].i = 0.f; + i__3 = j + (*n - *l + j) * b_dim1; + i__4 = j + (*n - *l + j) * b_dim1; + r__1 = b[i__4].r; + b[i__3].r = r__1, b[i__3].i = 0.f; + +/* Update unitary matrices U, V, Q, if desired. */ + + if (wantu && *k + j <= *m) { + crot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) * + u_dim1 + 1], &c__1, &csu, &snu); + } + + if (wantv) { + crot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1], + &c__1, &csv, &snv); + } + + if (wantq) { + crot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - * + l + i__) * q_dim1 + 1], &c__1, &csq, &snq); + } + +/* L10: */ + } +/* L20: */ + } + + if (! upper) { + +/* The matrices A13 and B13 were lower triangular at the start */ +/* of the cycle, and are now upper triangular. */ + +/* Convergence test: test the parallelism of the corresponding */ +/* rows of A and B. */ + + error = 0.f; +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l - i__ + 1; + ccopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, & + work[1], &c__1); + i__2 = *l - i__ + 1; + ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[* + l + 1], &c__1); + i__2 = *l - i__ + 1; + clapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin); + error = f2cmax(error,ssmin); +/* L30: */ + } + + if (abs(error) <= f2cmin(*tola,*tolb)) { + goto L50; + } + } + +/* End of cycle loop */ + +/* L40: */ + } + +/* The algorithm has not converged after MAXIT cycles. */ + + *info = 1; + goto L100; + +L50: + +/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */ +/* Compute the generalized singular value pairs (ALPHA, BETA), and */ +/* set the triangular matrix R to array A. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + alpha[i__] = 1.f; + beta[i__] = 0.f; +/* L60: */ + } + +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + + i__2 = *k + i__ + (*n - *l + i__) * a_dim1; + a1 = a[i__2].r; + i__2 = i__ + (*n - *l + i__) * b_dim1; + b1 = b[i__2].r; + gamma = b1 / a1; + + if (gamma <= (real) myhuge_(&c_b3) && gamma >= -((real) myhuge_(&c_b3) + )) { + + if (gamma < 0.f) { + i__2 = *l - i__ + 1; + csscal_(&i__2, &c_b40, &b[i__ + (*n - *l + i__) * b_dim1], + ldb); + if (wantv) { + csscal_(p, &c_b40, &v[i__ * v_dim1 + 1], &c__1); + } + } + + r__1 = abs(gamma); + slartg_(&r__1, &c_b43, &beta[*k + i__], &alpha[*k + i__], &rwk); + + if (alpha[*k + i__] >= beta[*k + i__]) { + i__2 = *l - i__ + 1; + r__1 = 1.f / alpha[*k + i__]; + csscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1], + lda); + } else { + i__2 = *l - i__ + 1; + r__1 = 1.f / beta[*k + i__]; + csscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb) + ; + i__2 = *l - i__ + 1; + ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + } + + } else { + alpha[*k + i__] = 0.f; + beta[*k + i__] = 1.f; + i__2 = *l - i__ + 1; + ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + } +/* L70: */ + } + +/* Post-assignment */ + + i__1 = *k + *l; + for (i__ = *m + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.f; + beta[i__] = 1.f; +/* L80: */ + } + + if (*k + *l < *n) { + i__1 = *n; + for (i__ = *k + *l + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.f; + beta[i__] = 0.f; +/* L90: */ + } + } + +L100: + *ncallmycycle = kcallmycycle; + + return 0; + +/* End of CTGSJA */ + +} /* ctgsja_ */ + diff --git a/lapack-netlib/SRC/ctgsna.c b/lapack-netlib/SRC/ctgsna.c new file mode 100644 index 000000000..aa4c18b83 --- /dev/null +++ b/lapack-netlib/SRC/ctgsna.c @@ -0,0 +1,963 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGSNA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGSNA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, */ +/* LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER HOWMNY, JOB */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* REAL DIF( * ), S( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGSNA estimates reciprocal condition numbers for specified */ +/* > eigenvalues and/or eigenvectors of a matrix pair (A, B). */ +/* > */ +/* > (A, B) must be in generalized Schur canonical form, that is, A and */ +/* > B are both upper triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for */ +/* > eigenvalues (S) or eigenvectors (DIF): */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for eigenvectors only (DIF); */ +/* > = 'B': for both eigenvalues and eigenvectors (S and DIF). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute condition numbers for all eigenpairs; */ +/* > = 'S': compute condition numbers for selected eigenpairs */ +/* > specified by the array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* > condition numbers are required. To select condition numbers */ +/* > for the corresponding j-th eigenvalue and/or eigenvector, */ +/* > SELECT(j) must be set to .TRUE.. */ +/* > If HOWMNY = 'A', SELECT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the square matrix pair (A, B). N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The upper triangular matrix A in the pair (A,B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > The upper triangular matrix B in the pair (A, B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is COMPLEX array, dimension (LDVL,M) */ +/* > IF JOB = 'E' or 'B', VL must contain left eigenvectors of */ +/* > (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* > and SELECT. The eigenvectors must be stored in consecutive */ +/* > columns of VL, as returned by CTGEVC. */ +/* > If JOB = 'V', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1; and */ +/* > If JOB = 'E' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VR */ +/* > \verbatim */ +/* > VR is COMPLEX array, dimension (LDVR,M) */ +/* > IF JOB = 'E' or 'B', VR must contain right eigenvectors of */ +/* > (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* > and SELECT. The eigenvectors must be stored in consecutive */ +/* > columns of VR, as returned by CTGEVC. */ +/* > If JOB = 'V', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1; */ +/* > If JOB = 'E' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (MM) */ +/* > If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* > selected eigenvalues, stored in consecutive elements of the */ +/* > array. */ +/* > If JOB = 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL array, dimension (MM) */ +/* > If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* > numbers of the selected eigenvectors, stored in consecutive */ +/* > elements of the array. */ +/* > If the eigenvalues cannot be reordered to compute DIF(j), */ +/* > DIF(j) is set to 0; this can only occur when the true value */ +/* > would be very small anyway. */ +/* > For each eigenvalue/vector specified by SELECT, DIF stores */ +/* > a Frobenius norm-based estimate of Difl. */ +/* > If JOB = 'E', DIF is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of elements in the arrays S and DIF. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of elements of the arrays S and DIF used to store */ +/* > the specified condition numbers; for each selected eigenvalue */ +/* > one element is used. If HOWMNY = 'A', M is set to 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. LWORK >= f2cmax(1,N). */ +/* > If JOB = 'V' or 'B', LWORK >= f2cmax(1,2*N*N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N+2) */ +/* > If JOB = 'E', IWORK 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 */ +/* > \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 reciprocal of the condition number of the i-th generalized */ +/* > eigenvalue w = (a, b) is defined as */ +/* > */ +/* > S(I) = (|v**HAu|**2 + |v**HBu|**2)**(1/2) / (norm(u)*norm(v)) */ +/* > */ +/* > where u and v are the right and left eigenvectors of (A, B) */ +/* > corresponding to w; |z| denotes the absolute value of the complex */ +/* > number, and norm(u) denotes the 2-norm of the vector u. The pair */ +/* > (a, b) corresponds to an eigenvalue w = a/b (= v**HAu/v**HBu) of the */ +/* > matrix pair (A, B). If both a and b equal zero, then (A,B) is */ +/* > singular and S(I) = -1 is returned. */ +/* > */ +/* > An approximate error bound on the chordal distance between the i-th */ +/* > computed generalized eigenvalue w and the corresponding exact */ +/* > eigenvalue lambda is */ +/* > */ +/* > chord(w, lambda) <= EPS * norm(A, B) / S(I), */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal of the condition number of the right eigenvector u */ +/* > and left eigenvector v corresponding to the generalized eigenvalue w */ +/* > is defined as follows. Suppose */ +/* > */ +/* > (A, B) = ( a * ) ( b * ) 1 */ +/* > ( 0 A22 ),( 0 B22 ) n-1 */ +/* > 1 n-1 1 n-1 */ +/* > */ +/* > Then the reciprocal condition number DIF(I) is */ +/* > */ +/* > Difl[(a, b), (A22, B22)] = sigma-f2cmin( Zl ) */ +/* > */ +/* > where sigma-f2cmin(Zl) denotes the smallest singular value of */ +/* > */ +/* > Zl = [ kron(a, In-1) -kron(1, A22) ] */ +/* > [ kron(b, In-1) -kron(1, B22) ]. */ +/* > */ +/* > Here In-1 is the identity matrix of size n-1 and X**H is the conjugate */ +/* > transpose of X. kron(X, Y) is the Kronecker product between the */ +/* > matrices X and Y. */ +/* > */ +/* > We approximate the smallest singular value of Zl with an upper */ +/* > bound. This is done by CLATDF. */ +/* > */ +/* > An approximate error bound for a computed eigenvector VL(i) or */ +/* > VR(i) is given by */ +/* > */ +/* > EPS * norm(A, B) / DIF(i). */ +/* > */ +/* > See ref. [2-3] for more details and further references. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, Report */ +/* > UMINF - 94.04, Department of Computing Science, Umea University, */ +/* > S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */ +/* > To appear in Numerical Algorithms, 1996. */ +/* > */ +/* > [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. */ +/* > To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctgsna_(char *job, char *howmny, logical *select, + integer *n, complex *a, integer *lda, complex *b, integer *ldb, + complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real + *dif, integer *mm, integer *m, complex *work, integer *lwork, integer + *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1; + real r__1, r__2; + complex q__1; + + /* Local variables */ + real cond; + integer ierr, ifst; + real lnrm; + complex yhax, yhbx; + integer ilst; + real rnrm; + integer i__, k; + real scale; + 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 *); + integer lwmin; + logical wants; + complex dummy[1]; + integer n1, n2; + extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, + real *); + complex dummy1[1]; + extern /* Subroutine */ int slabad_(real *, real *); + integer ks; + extern real slamch_(char *); + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), ctgexc_(logical *, + logical *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, integer *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + real bignum; + logical wantbh, wantdf, somcon; + extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer + *, complex *, integer *, complex *, integer *, complex *, integer + *, complex *, integer *, complex *, integer *, complex *, integer + *, real *, real *, complex *, integer *, integer *, integer *); + real smlnum; + logical lquery; + 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 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --s; + --dif; + --work; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantdf = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + + *info = 0; + lquery = *lwork == -1; + + if (! wants && ! wantdf) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (wants && *ldvl < *n) { + *info = -10; + } else if (wants && *ldvr < *n) { + *info = -12; + } else { + +/* Set M to the number of eigenpairs for which condition numbers */ +/* are required, and test MM. */ + + if (somcon) { + *m = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (select[k]) { + ++(*m); + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*n == 0) { + lwmin = 1; + } else if (lsame_(job, "V") || lsame_(job, + "B")) { + lwmin = (*n << 1) * *n; + } else { + lwmin = *n; + } + work[1].r = (real) lwmin, work[1].i = 0.f; + + if (*mm < *m) { + *info = -15; + } else if (*lwork < lwmin && ! lquery) { + *info = -18; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGSNA", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + ks = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Determine whether condition numbers are required for the k-th */ +/* eigenpair. */ + + if (somcon) { + if (! select[k]) { + goto L20; + } + } + + ++ks; + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + cgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + 1] + , &c__1, &c_b20, &work[1], &c__1); + cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1); + yhax.r = q__1.r, yhax.i = q__1.i; + cgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + 1] + , &c__1, &c_b20, &work[1], &c__1); + cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1); + yhbx.r = q__1.r, yhbx.i = q__1.i; + r__1 = c_abs(&yhax); + r__2 = c_abs(&yhbx); + cond = slapy2_(&r__1, &r__2); + if (cond == 0.f) { + s[ks] = -1.f; + } else { + s[ks] = cond / (rnrm * lnrm); + } + } + + if (wantdf) { + if (*n == 1) { + r__1 = c_abs(&a[a_dim1 + 1]); + r__2 = c_abs(&b[b_dim1 + 1]); + dif[ks] = slapy2_(&r__1, &r__2); + } else { + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvectors. */ + +/* Copy the matrix (A, B) to the array WORK and move the */ +/* (k,k)th pair to the (1,1) position. */ + + clacpy_("Full", n, n, &a[a_offset], lda, &work[1], n); + clacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], + n); + ifst = k; + ilst = 1; + + ctgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1] + , n, dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr) + ; + + if (ierr > 0) { + +/* Ill-conditioned problem - swap rejected. */ + + dif[ks] = 0.f; + } else { + +/* Reordering successful, solve generalized Sylvester */ +/* equation for R and L, */ +/* A22 * R - L * A11 = A12 */ +/* B22 * R - L * B11 = B12, */ +/* and compute estimate of Difl[(A11,B11), (A22, B22)]. */ + + n1 = 1; + n2 = *n - n1; + i__ = *n * *n + 1; + ctgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, + &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 + + i__], n, &work[i__], n, &work[n1 + i__], n, & + scale, &dif[ks], dummy, &c__1, &iwork[1], &ierr); + } + } + } + +L20: + ; + } + work[1].r = (real) lwmin, work[1].i = 0.f; + return 0; + +/* End of CTGSNA */ + +} /* ctgsna_ */ + diff --git a/lapack-netlib/SRC/ctgsy2.c b/lapack-netlib/SRC/ctgsy2.c new file mode 100644 index 000000000..c12f5fac9 --- /dev/null +++ b/lapack-netlib/SRC/ctgsy2.c @@ -0,0 +1,941 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGSY2 solves the generalized Sylvester equation (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGSY2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, */ +/* LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, */ +/* INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N */ +/* REAL RDSCAL, RDSUM, SCALE */ +/* COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGSY2 solves the generalized Sylvester equation */ +/* > */ +/* > A * R - L * B = scale * C (1) */ +/* > D * R - L * E = scale * F */ +/* > */ +/* > using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices, */ +/* > (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */ +/* > N-by-N and M-by-N, respectively. A, B, D and E are upper triangular */ +/* > (i.e., (A,D) and (B,E) in generalized Schur form). */ +/* > */ +/* > The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */ +/* > scaling factor chosen to avoid overflow. */ +/* > */ +/* > In matrix notation solving equation (1) corresponds to solve */ +/* > Zx = scale * b, where Z is defined as */ +/* > */ +/* > Z = [ kron(In, A) -kron(B**H, Im) ] (2) */ +/* > [ kron(In, D) -kron(E**H, Im) ], */ +/* > */ +/* > Ik is the identity matrix of size k and X**H is the transpose of X. */ +/* > kron(X, Y) is the Kronecker product between the matrices X and Y. */ +/* > */ +/* > If TRANS = 'C', y in the conjugate transposed system Z**H*y = scale*b */ +/* > is solved for, which is equivalent to solve for R and L in */ +/* > */ +/* > A**H * R + D**H * L = scale * C (3) */ +/* > R * B**H + L * E**H = scale * -F */ +/* > */ +/* > This case is used to compute an estimate of Dif[(A, D), (B, E)] = */ +/* > = sigma_min(Z) using reverse communication with CLACON. */ +/* > */ +/* > CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL */ +/* > of an upper bound on the separation between to matrix pairs. Then */ +/* > the input (A, D), (B, E) are sub-pencils of two matrix pairs in */ +/* > CTGSYL. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': solve the generalized Sylvester equation (1). */ +/* > = 'T': solve the 'transposed' system (3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies what kind of functionality to be performed. */ +/* > = 0: solve (1) only. */ +/* > = 1: A contribution from this subsystem to a Frobenius */ +/* > norm-based estimate of the separation between two matrix */ +/* > pairs is computed. (look ahead strategy is used). */ +/* > = 2: A contribution from this subsystem to a Frobenius */ +/* > norm-based estimate of the separation between two matrix */ +/* > pairs is computed. (SGECON on sub-systems is used.) */ +/* > Not referenced if TRANS = 'T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the order of A and D, and the row */ +/* > dimension of C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the order of B and E, and the column */ +/* > dimension of C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, M) */ +/* > On entry, A contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the matrix A. LDA >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB, N) */ +/* > On entry, B contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the matrix B. LDB >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC, N) */ +/* > On entry, C contains the right-hand-side of the first matrix */ +/* > equation in (1). */ +/* > On exit, if IJOB = 0, C has been overwritten by the solution */ +/* > R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the matrix C. LDC >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension (LDD, M) */ +/* > On entry, D contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of the matrix D. LDD >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (LDE, N) */ +/* > On entry, E contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of the matrix E. LDE >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is COMPLEX array, dimension (LDF, N) */ +/* > On entry, F contains the right-hand-side of the second matrix */ +/* > equation in (1). */ +/* > On exit, if IJOB = 0, F has been overwritten by the solution */ +/* > L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the matrix F. LDF >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */ +/* > R and L (C and F on entry) will hold the solutions to a */ +/* > slightly perturbed system but the input matrices A, B, D and */ +/* > E have not been changed. If SCALE = 0, R and L will hold the */ +/* > solutions to the homogeneous system with C = F = 0. */ +/* > Normally, SCALE = 1. */ +/* > \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[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, if INFO is set to */ +/* > =0: Successful exit */ +/* > <0: If INFO = -i, input argument number i is illegal. */ +/* > >0: The matrix pairs (A, D) and (B, E) have common or very */ +/* > close eigenvalues. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* ===================================================================== */ +/* Subroutine */ int ctgsy2_(char *trans, integer *ijob, integer *m, integer * + n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, + integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde, + complex *f, integer *ldf, real *scale, real *rdsum, real *rdscal, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, + i__4; + complex q__1, q__2, q__3, q__4, q__5, q__6; + + /* Local variables */ + integer ierr, ipiv[2], jpiv[2], i__, j, k; + complex alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + complex z__[4] /* was [2][2] */; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *), cgesc2_(integer *, complex *, + integer *, complex *, integer *, integer *, real *), cgetc2_( + integer *, complex *, integer *, integer *, integer *, integer *), + clatdf_(integer *, integer *, complex *, integer *, complex *, + real *, real *, integer *, integer *); + real scaloc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + complex rhs[2]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + + /* Function Body */ + *info = 0; + ierr = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "C")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 2) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*ldd < f2cmax(1,*m)) { + *info = -12; + } else if (*lde < f2cmax(1,*n)) { + *info = -14; + } else if (*ldf < f2cmax(1,*m)) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGSY2", &i__1, (ftnlen)6); + return 0; + } + + if (notran) { + +/* Solve (I, J) - system */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = M, M - 1, ..., 1; J = 1, 2, ..., N */ + + *scale = 1.f; + scaloc = 1.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + +/* Build 2 by 2 system */ + + i__2 = i__ + i__ * a_dim1; + z__[0].r = a[i__2].r, z__[0].i = a[i__2].i; + i__2 = i__ + i__ * d_dim1; + z__[1].r = d__[i__2].r, z__[1].i = d__[i__2].i; + i__2 = j + j * b_dim1; + q__1.r = -b[i__2].r, q__1.i = -b[i__2].i; + z__[2].r = q__1.r, z__[2].i = q__1.i; + i__2 = j + j * e_dim1; + q__1.r = -e[i__2].r, q__1.i = -e[i__2].i; + z__[3].r = q__1.r, z__[3].i = q__1.i; + +/* Set up right hand side(s) */ + + i__2 = i__ + j * c_dim1; + rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i; + i__2 = i__ + j * f_dim1; + rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i; + +/* Solve Z * x = RHS */ + + cgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + if (*ijob == 0) { + cgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1); + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + } else { + clatdf_(ijob, &c__2, z__, &c__2, rhs, rdsum, rdscal, ipiv, + jpiv); + } + +/* Unpack solution vector(s) */ + + i__2 = i__ + j * c_dim1; + c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i; + i__2 = i__ + j * f_dim1; + f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i; + +/* Substitute R(I, J) and L(I, J) into remaining equation. */ + + if (i__ > 1) { + q__1.r = -rhs[0].r, q__1.i = -rhs[0].i; + 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, &c__[j + * c_dim1 + 1], &c__1); + i__2 = i__ - 1; + caxpy_(&i__2, &alpha, &d__[i__ * d_dim1 + 1], &c__1, &f[j + * f_dim1 + 1], &c__1); + } + if (j < *n) { + i__2 = *n - j; + caxpy_(&i__2, &rhs[1], &b[j + (j + 1) * b_dim1], ldb, & + c__[i__ + (j + 1) * c_dim1], ldc); + i__2 = *n - j; + caxpy_(&i__2, &rhs[1], &e[j + (j + 1) * e_dim1], lde, &f[ + i__ + (j + 1) * f_dim1], ldf); + } + +/* L20: */ + } +/* L30: */ + } + } else { + +/* Solve transposed (I, J) - system: */ +/* A(I, I)**H * R(I, J) + D(I, I)**H * L(J, J) = C(I, J) */ +/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */ +/* for I = 1, 2, ..., M, J = N, N - 1, ..., 1 */ + + *scale = 1.f; + scaloc = 1.f; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + for (j = *n; j >= 1; --j) { + +/* Build 2 by 2 system Z**H */ + + r_cnjg(&q__1, &a[i__ + i__ * a_dim1]); + z__[0].r = q__1.r, z__[0].i = q__1.i; + r_cnjg(&q__2, &b[j + j * b_dim1]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + z__[1].r = q__1.r, z__[1].i = q__1.i; + r_cnjg(&q__1, &d__[i__ + i__ * d_dim1]); + z__[2].r = q__1.r, z__[2].i = q__1.i; + r_cnjg(&q__2, &e[j + j * e_dim1]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + z__[3].r = q__1.r, z__[3].i = q__1.i; + + +/* Set up right hand side(s) */ + + i__2 = i__ + j * c_dim1; + rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i; + i__2 = i__ + j * f_dim1; + rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i; + +/* Solve Z**H * x = RHS */ + + cgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + cgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1); + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + i__2 = i__ + j * c_dim1; + c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i; + i__2 = i__ + j * f_dim1; + f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i; + +/* Substitute R(I, J) and L(I, J) into remaining equation. */ + + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = i__ + k * f_dim1; + i__4 = i__ + k * f_dim1; + r_cnjg(&q__4, &b[k + j * b_dim1]); + q__3.r = rhs[0].r * q__4.r - rhs[0].i * q__4.i, q__3.i = + rhs[0].r * q__4.i + rhs[0].i * q__4.r; + q__2.r = f[i__4].r + q__3.r, q__2.i = f[i__4].i + q__3.i; + r_cnjg(&q__6, &e[k + j * e_dim1]); + q__5.r = rhs[1].r * q__6.r - rhs[1].i * q__6.i, q__5.i = + rhs[1].r * q__6.i + rhs[1].i * q__6.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + f[i__3].r = q__1.r, f[i__3].i = q__1.i; +/* L50: */ + } + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + i__3 = k + j * c_dim1; + i__4 = k + j * c_dim1; + r_cnjg(&q__4, &a[i__ + k * a_dim1]); + q__3.r = q__4.r * rhs[0].r - q__4.i * rhs[0].i, q__3.i = + q__4.r * rhs[0].i + q__4.i * rhs[0].r; + q__2.r = c__[i__4].r - q__3.r, q__2.i = c__[i__4].i - + q__3.i; + r_cnjg(&q__6, &d__[i__ + k * d_dim1]); + q__5.r = q__6.r * rhs[1].r - q__6.i * rhs[1].i, q__5.i = + q__6.r * rhs[1].i + q__6.i * rhs[1].r; + q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L60: */ + } + +/* L70: */ + } +/* L80: */ + } + } + return 0; + +/* End of CTGSY2 */ + +} /* ctgsy2_ */ + diff --git a/lapack-netlib/SRC/ctgsyl.c b/lapack-netlib/SRC/ctgsyl.c new file mode 100644 index 000000000..c2196b6a4 --- /dev/null +++ b/lapack-netlib/SRC/ctgsyl.c @@ -0,0 +1,1172 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTGSYL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTGSYL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, */ +/* LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, */ +/* $ LWORK, M, N */ +/* REAL DIF, SCALE */ +/* INTEGER IWORK( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTGSYL solves the generalized Sylvester equation: */ +/* > */ +/* > A * R - L * B = scale * C (1) */ +/* > D * R - L * E = scale * F */ +/* > */ +/* > where R and L are unknown m-by-n matrices, (A, D), (B, E) and */ +/* > (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */ +/* > respectively, with complex entries. A, B, D and E are upper */ +/* > triangular (i.e., (A,D) and (B,E) in generalized Schur form). */ +/* > */ +/* > The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 */ +/* > is an output scaling factor chosen to avoid overflow. */ +/* > */ +/* > In matrix notation (1) is equivalent to solve Zx = scale*b, where Z */ +/* > is defined as */ +/* > */ +/* > Z = [ kron(In, A) -kron(B**H, Im) ] (2) */ +/* > [ kron(In, D) -kron(E**H, Im) ], */ +/* > */ +/* > Here Ix is the identity matrix of size x and X**H is the conjugate */ +/* > transpose of X. Kron(X, Y) is the Kronecker product between the */ +/* > matrices X and Y. */ +/* > */ +/* > If TRANS = 'C', y in the conjugate transposed system Z**H *y = scale*b */ +/* > is solved for, which is equivalent to solve for R and L in */ +/* > */ +/* > A**H * R + D**H * L = scale * C (3) */ +/* > R * B**H + L * E**H = scale * -F */ +/* > */ +/* > This case (TRANS = 'C') is used to compute an one-norm-based estimate */ +/* > of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */ +/* > and (B,E), using CLACON. */ +/* > */ +/* > If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of */ +/* > Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */ +/* > reciprocal of the smallest singular value of Z. */ +/* > */ +/* > This is a level-3 BLAS algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': solve the generalized sylvester equation (1). */ +/* > = 'C': solve the "conjugate transposed" system (3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies what kind of functionality to be performed. */ +/* > =0: solve (1) only. */ +/* > =1: The functionality of 0 and 3. */ +/* > =2: The functionality of 0 and 4. */ +/* > =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* > (look ahead strategy is used). */ +/* > =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* > (CGECON on sub-systems is used). */ +/* > Not referenced if TRANS = 'C'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The order of the matrices A and D, and the row dimension of */ +/* > the matrices C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices B and E, and the column dimension */ +/* > of the matrices C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, M) */ +/* > The upper triangular matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB, N) */ +/* > The upper triangular 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] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC, N) */ +/* > On entry, C contains the right-hand-side of the first matrix */ +/* > equation in (1) or (3). */ +/* > On exit, if IJOB = 0, 1 or 2, C has been overwritten by */ +/* > the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */ +/* > the solution achieved during the computation of the */ +/* > Dif-estimate. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension (LDD, M) */ +/* > The upper triangular matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of the array D. LDD >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (LDE, N) */ +/* > The upper triangular matrix E. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of the array E. LDE >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is COMPLEX array, dimension (LDF, N) */ +/* > On entry, F contains the right-hand-side of the second matrix */ +/* > equation in (1) or (3). */ +/* > On exit, if IJOB = 0, 1 or 2, F has been overwritten by */ +/* > the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */ +/* > the solution achieved during the computation of the */ +/* > Dif-estimate. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the array F. LDF >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL */ +/* > On exit DIF is the reciprocal of a lower bound of the */ +/* > reciprocal of the Dif-function, i.e. DIF is an upper bound of */ +/* > Dif[(A,D), (B,E)] = sigma-f2cmin(Z), where Z as in (2). */ +/* > IF IJOB = 0 or TRANS = 'C', DIF is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > On exit SCALE is the scaling factor in (1) or (3). */ +/* > If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */ +/* > to a slightly perturbed system but the input matrices A, B, */ +/* > D and E have not been changed. If SCALE = 0, R and L will */ +/* > hold the solutions to the homogenious system with C = F = 0. */ +/* > \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. LWORK > = 1. */ +/* > If IJOB = 1 or 2 and TRANS = 'N', LWORK >= f2cmax(1,2*M*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 (M+N+2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: successful exit */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > >0: (A, D) and (B, E) have common or very close */ +/* > eigenvalues. */ +/* > \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: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ +/* > No 1, 1996. */ +/* > \n */ +/* > [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */ +/* > Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */ +/* > Appl., 15(4):1045-1060, 1994. */ +/* > \n */ +/* > [3] B. Kagstrom and L. 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. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer * + n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, + integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde, + complex *f, integer *ldf, real *scale, real *dif, complex *work, + integer *lwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, + i__4; + complex q__1; + + /* Local variables */ + real dsum; + integer i__, j, k, p, q; + 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 *); + integer ifunc, linfo, lwmin; + real scale2; + extern /* Subroutine */ int ctgsy2_(char *, integer *, integer *, integer + *, complex *, integer *, complex *, integer *, complex *, integer + *, complex *, integer *, complex *, integer *, complex *, integer + *, real *, real *, real *, integer *); + integer ie, je, mb, nb; + real dscale; + integer is, js, pq; + real scaloc; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), claset_(char *, + integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer iround; + logical notran; + integer isolve; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ +/* Replaced various illegal calls to CCOPY by calls to CLASET. */ +/* Sven Hammarling, 1/5/02. */ + + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + + if (! notran && ! lsame_(trans, "C")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 4) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*ldd < f2cmax(1,*m)) { + *info = -12; + } else if (*lde < f2cmax(1,*n)) { + *info = -14; + } else if (*ldf < f2cmax(1,*m)) { + *info = -16; + } + } + + if (*info == 0) { + if (notran) { + if (*ijob == 1 || *ijob == 2) { +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * *n; + lwmin = f2cmax(i__1,i__2); + } else { + lwmin = 1; + } + } else { + lwmin = 1; + } + work[1].r = (real) lwmin, work[1].i = 0.f; + + if (*lwork < lwmin && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTGSYL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *scale = 1.f; + if (notran) { + if (*ijob != 0) { + *dif = 0.f; + } + } + return 0; + } + +/* Determine optimal block sizes MB and NB */ + + mb = ilaenv_(&c__2, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb = ilaenv_(&c__5, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + + isolve = 1; + ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + claset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc); + claset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf); + } else if (*ijob >= 1 && notran) { + isolve = 2; + } + } + + if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) { + +/* Use unblocked Level 2 solver */ + + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + + *scale = 1.f; + dscale = 0.f; + dsum = 1.f; + pq = *m * *n; + ctgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb, + &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset], + lde, &f[f_offset], ldf, scale, &dsum, &dscale, info); + if (dscale != 0.f) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( + dsum)); + } else { + *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); + } + } + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + claset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc); + claset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf) + ; + } else if (isolve == 2 && iround == 2) { + clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L30: */ + } + + return 0; + + } + +/* Determine block structure of A */ + + p = 0; + i__ = 1; +L40: + if (i__ > *m) { + goto L50; + } + ++p; + iwork[p] = i__; + i__ += mb; + if (i__ >= *m) { + goto L50; + } + goto L40; +L50: + iwork[p + 1] = *m + 1; + if (iwork[p] == iwork[p + 1]) { + --p; + } + +/* Determine block structure of B */ + + q = p + 1; + j = 1; +L60: + if (j > *n) { + goto L70; + } + + ++q; + iwork[q] = j; + j += nb; + if (j >= *n) { + goto L70; + } + goto L60; + +L70: + iwork[q + 1] = *n + 1; + if (iwork[q] == iwork[q + 1]) { + --q; + } + + if (notran) { + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + +/* Solve (I, J) - subsystem */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */ + + pq = 0; + *scale = 1.f; + dscale = 0.f; + dsum = 1.f; + i__2 = q; + for (j = p + 2; j <= i__2; ++j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + for (i__ = p; i__ >= 1; --i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + ctgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], + lda, &b[js + js * b_dim1], ldb, &c__[is + js * + c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js + + js * e_dim1], lde, &f[is + js * f_dim1], ldf, & + scaloc, &dsum, &dscale, &linfo); + if (linfo > 0) { + *info = linfo; + } + pq += mb * nb; + if (scaloc != 1.f) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1); + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L80: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &c__[k * c_dim1 + 1], &c__1); + i__4 = is - 1; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L90: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &c__[ie + 1 + k * c_dim1], & + c__1); + i__4 = *m - ie; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &f[ie + 1 + k * f_dim1], & + c__1); +/* L100: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1); + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L110: */ + } + *scale *= scaloc; + } + +/* Substitute R(I,J) and L(I,J) into remaining equation. */ + + if (i__ > 1) { + i__3 = is - 1; + cgemm_("N", "N", &i__3, &nb, &mb, &c_b44, &a[is * + a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc, + &c_b45, &c__[js * c_dim1 + 1], ldc); + i__3 = is - 1; + cgemm_("N", "N", &i__3, &nb, &mb, &c_b44, &d__[is * + d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc, + &c_b45, &f[js * f_dim1 + 1], ldf); + } + if (j < q) { + i__3 = *n - je; + cgemm_("N", "N", &mb, &i__3, &nb, &c_b45, &f[is + js * + f_dim1], ldf, &b[js + (je + 1) * b_dim1], + ldb, &c_b45, &c__[is + (je + 1) * c_dim1], + ldc); + i__3 = *n - je; + cgemm_("N", "N", &mb, &i__3, &nb, &c_b45, &f[is + js * + f_dim1], ldf, &e[js + (je + 1) * e_dim1], + lde, &c_b45, &f[is + (je + 1) * f_dim1], ldf); + } +/* L120: */ + } +/* L130: */ + } + if (dscale != 0.f) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( + dsum)); + } else { + *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); + } + } + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + claset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc); + claset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf) + ; + } else if (isolve == 2 && iround == 2) { + clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L150: */ + } + } else { + +/* Solve transposed (I, J)-subsystem */ +/* A(I, I)**H * R(I, J) + D(I, I)**H * L(I, J) = C(I, J) */ +/* R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */ +/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */ + + *scale = 1.f; + i__1 = p; + for (i__ = 1; i__ <= i__1; ++i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + i__2 = p + 2; + for (j = q; j >= i__2; --j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + ctgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, & + b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc, + &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1], + lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, & + dscale, &linfo); + if (linfo > 0) { + *info = linfo; + } + if (scaloc != 1.f) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1); + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L160: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &c__[k * c_dim1 + 1], &c__1); + i__4 = is - 1; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L170: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &c__[ie + 1 + k * c_dim1], &c__1) + ; + i__4 = *m - ie; + q__1.r = scaloc, q__1.i = 0.f; + cscal_(&i__4, &q__1, &f[ie + 1 + k * f_dim1], &c__1); +/* L180: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1); + q__1.r = scaloc, q__1.i = 0.f; + cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1); +/* L190: */ + } + *scale *= scaloc; + } + +/* Substitute R(I,J) and L(I,J) into remaining equation. */ + + if (j > p + 2) { + i__3 = js - 1; + cgemm_("N", "C", &mb, &i__3, &nb, &c_b45, &c__[is + js * + c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b45, & + f[is + f_dim1], ldf); + i__3 = js - 1; + cgemm_("N", "C", &mb, &i__3, &nb, &c_b45, &f[is + js * + f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b45, & + f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + cgemm_("C", "N", &i__3, &nb, &mb, &c_b44, &a[is + (ie + 1) + * a_dim1], lda, &c__[is + js * c_dim1], ldc, & + c_b45, &c__[ie + 1 + js * c_dim1], ldc); + i__3 = *m - ie; + cgemm_("C", "N", &i__3, &nb, &mb, &c_b44, &d__[is + (ie + + 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, & + c_b45, &c__[ie + 1 + js * c_dim1], ldc); + } +/* L200: */ + } +/* L210: */ + } + } + + work[1].r = (real) lwmin, work[1].i = 0.f; + + return 0; + +/* End of CTGSYL */ + +} /* ctgsyl_ */ + diff --git a/lapack-netlib/SRC/ctpcon.c b/lapack-netlib/SRC/ctpcon.c new file mode 100644 index 000000000..7f76bc5b1 --- /dev/null +++ b/lapack-netlib/SRC/ctpcon.c @@ -0,0 +1,665 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, N */ +/* REAL RCOND */ +/* REAL RWORK( * ) */ +/* COMPLEX AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPCON estimates the reciprocal of the condition number of a packed */ +/* > triangular matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \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. */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \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 ctpcon_(char *norm, char *uplo, char *diag, integer *n, + complex *ap, real *rcond, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + integer kase, kase1; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + real anorm; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + real xnorm; + integer ix; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern real clantp_(char *, char *, char *, integer *, complex *, real *); + extern /* Subroutine */ int clatps_(char *, char *, char *, char *, + integer *, complex *, complex *, real *, real *, integer *); + real ainvnm; + extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer + *); + logical onenrm; + char normin[1]; + real smlnum; + logical nounit; + + +/* -- 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"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.f; + return 0; + } + + *rcond = 0.f; + smlnum = slamch_("Safe minimum") * (real) f2cmax(1,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.f) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.f; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ + 1], &scale, &rwork[1], info); + } else { + +/* Multiply by inv(A**H). */ + + clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1], + &work[1], &scale, &rwork[1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.f) { + ix = icamax_(n, &work[1], &c__1); + i__1 = ix; + xnorm = (r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& + work[ix]), abs(r__2)); + if (scale < xnorm * 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 / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of CTPCON */ + +} /* ctpcon_ */ + diff --git a/lapack-netlib/SRC/ctplqt.c b/lapack-netlib/SRC/ctplqt.c new file mode 100644 index 000000000..d52ddf82e --- /dev/null +++ b/lapack-netlib/SRC/ctplqt.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 CTPLQT */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB */ +/* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPLQT computes a blocked LQ factorization of a complex */ +/* > "triangular-pentagonal" matrix C, which is composed of a */ +/* > triangular block A and pentagonal block B, using the compact */ +/* > WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B, and the order of the */ +/* > triangular matrix A. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the lower trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size to be used in the blocked QR. M >= MB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,M) */ +/* > On entry, the lower triangular M-by-M matrix A. */ +/* > On exit, the elements on and below the diagonal of the array */ +/* > contain the lower triangular matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first N-L columns */ +/* > are rectangular, and the last L columns are lower trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > The lower triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MB*M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a M-by-(M+N) matrix */ +/* > */ +/* > C = [ A ] [ B ] */ +/* > */ +/* > */ +/* > where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L */ +/* > upper trapezoidal matrix B2: */ +/* > [ B ] = [ B1 ] [ B2 ] */ +/* > [ B1 ] <- M-by-(N-L) rectangular */ +/* > [ B2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The lower trapezoidal matrix B2 consists of the first L columns of a */ +/* > M-by-M lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is lower triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal (of A) in the M-by-(M+N) input matrix C */ +/* > [ C ] = [ A ] [ B ] */ +/* > [ A ] <- lower triangular M-by-M */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > [ W ] = [ I ] [ V ] */ +/* > [ I ] <- identity, M-by-M */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > [ V ] = [ V1 ] [ V2 ] */ +/* > [ V1 ] <- M-by-(N-L) rectangular */ +/* > [ V2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The rows of V represent the vectors which define the H(i)'s. */ +/* > */ +/* > The number of blocks is B = ceiling(M/MB), where each */ +/* > block is of order MB except for the last block, which is of order */ +/* > IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB */ +/* > for the last block) T's are stored in the MB-by-N matrix T as */ +/* > */ +/* > T = [T1 T2 ... TB]. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctplqt_(integer *m, integer *n, integer *l, integer *mb, + complex *a, integer *lda, complex *b, integer *ldb, complex *t, + integer *ldt, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3, i__4; + + /* Local variables */ + integer i__, iinfo, ib, lb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), ctprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *), ctplqt2_(integer *, integer *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n) && f2cmin(*m,*n) >= 0) { + *info = -3; + } else if (*mb < 1 || *mb > *m && *m > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*m)) { + *info = -8; + } else if (*ldt < *mb) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPLQT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *m; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block */ + +/* Computing MIN */ + i__3 = *m - i__ + 1; + ib = f2cmin(i__3,*mb); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + + ctplqt2_(&ib, &nb, &lb, &a[i__ + i__ * a_dim1], lda, &b[i__ + b_dim1], + ldb, &t[i__ * t_dim1 + 1], ldt, &iinfo); + +/* Update by applying H**T to B(I+IB:M,:) from the right */ + + if (i__ + ib <= *m) { + i__3 = *m - i__ - ib + 1; + i__4 = *m - i__ - ib + 1; + ctprfb_("R", "N", "F", "R", &i__3, &nb, &ib, &lb, &b[i__ + b_dim1] + , ldb, &t[i__ * t_dim1 + 1], ldt, &a[i__ + ib + i__ * + a_dim1], lda, &b[i__ + ib + b_dim1], ldb, &work[1], &i__4); + } + } + return 0; + +/* End of CTPLQT */ + +} /* ctplqt_ */ + diff --git a/lapack-netlib/SRC/ctplqt2.c b/lapack-netlib/SRC/ctplqt2.c new file mode 100644 index 000000000..86cc9b5d7 --- /dev/null +++ b/lapack-netlib/SRC/ctplqt2.c @@ -0,0 +1,787 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPLQT2 */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L */ +/* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal" */ +/* > matrix C, which is composed of a triangular block A and pentagonal block B, */ +/* > using the compact WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of */ +/* > the triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the lower trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,M) */ +/* > On entry, the lower triangular M-by-M matrix A. */ +/* > On exit, the elements on and below the diagonal of the array */ +/* > contain the lower triangular matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first N-L columns */ +/* > are rectangular, and the last L columns are lower trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,M) */ +/* > The N-by-N upper triangular factor T of the block reflector. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a M-by-(M+N) matrix */ +/* > */ +/* > C = [ A ][ B ] */ +/* > */ +/* > */ +/* > where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ][ B2 ] */ +/* > [ B1 ] <- M-by-(N-L) rectangular */ +/* > [ B2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The lower trapezoidal matrix B2 consists of the first L columns of a */ +/* > N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is lower triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal (of A) in the M-by-(M+N) input matrix C */ +/* > */ +/* > C = [ A ][ B ] */ +/* > [ A ] <- lower triangular M-by-M */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ][ V ] */ +/* > [ I ] <- identity, M-by-M */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > W = [ V1 ][ V2 ] */ +/* > [ V1 ] <- M-by-(N-L) rectangular */ +/* > [ V2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The rows of V represent the vectors which define the H(i)'s. */ +/* > The (M+N)-by-(M+N) block reflector H is then given by */ +/* > */ +/* > H = I - W**T * T * W */ +/* > */ +/* > where W^H is the conjugate transpose of W and T is the upper triangular */ +/* > factor of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctplqt2_(integer *m, integer *n, integer *l, complex *a, + integer *lda, complex *b, integer *ldb, complex *t, integer *ldt, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3, i__4, i__5; + complex q__1, q__2; + + /* Local variables */ + integer i__, j, p; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *); + complex alpha; + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), ctrmv_(char *, char *, char *, integer *, + complex *, integer *, complex *, integer *); + integer mp, np; + extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, + integer *, complex *), xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n)) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldb < f2cmax(1,*m)) { + *info = -7; + } else if (*ldt < f2cmax(1,*m)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPLQT2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(I) to annihilate B(I,:) */ + + p = *n - *l + f2cmin(*l,i__); + i__2 = p + 1; + clarfg_(&i__2, &a[i__ + i__ * a_dim1], &b[i__ + b_dim1], ldb, &t[i__ * + t_dim1 + 1]); + i__2 = i__ * t_dim1 + 1; + r_cnjg(&q__1, &t[i__ * t_dim1 + 1]); + t[i__2].r = q__1.r, t[i__2].i = q__1.i; + if (i__ < *m) { + i__2 = p; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + r_cnjg(&q__1, &b[i__ + j * b_dim1]); + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + +/* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] */ + + i__2 = *m - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = *m + j * t_dim1; + i__4 = i__ + j + i__ * a_dim1; + t[i__3].r = a[i__4].r, t[i__3].i = a[i__4].i; + } + i__2 = *m - i__; + cgemv_("N", &i__2, &p, &c_b2, &b[i__ + 1 + b_dim1], ldb, &b[i__ + + b_dim1], ldb, &c_b2, &t[*m + t_dim1], ldt); + +/* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H */ + + i__2 = i__ * t_dim1 + 1; + q__1.r = -t[i__2].r, q__1.i = -t[i__2].i; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = *m - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j + i__ * a_dim1; + i__4 = i__ + j + i__ * a_dim1; + i__5 = *m + j * t_dim1; + q__2.r = alpha.r * t[i__5].r - alpha.i * t[i__5].i, q__2.i = + alpha.r * t[i__5].i + alpha.i * t[i__5].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; + } + i__2 = *m - i__; + q__1.r = alpha.r, q__1.i = alpha.i; + cgerc_(&i__2, &p, &q__1, &t[*m + t_dim1], ldt, &b[i__ + b_dim1], + ldb, &b[i__ + 1 + b_dim1], ldb); + i__2 = p; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + r_cnjg(&q__1, &b[i__ + j * b_dim1]); + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + } + + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T(I,1:I-1) := C(I:I-1,1:N)**H * (alpha * C(I,I:N)) */ + + i__2 = i__ * t_dim1 + 1; + q__1.r = -t[i__2].r, q__1.i = -t[i__2].i; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * t_dim1; + t[i__3].r = 0.f, t[i__3].i = 0.f; + } +/* Computing MIN */ + i__2 = i__ - 1; + p = f2cmin(i__2,*l); +/* Computing MIN */ + i__2 = *n - *l + 1; + np = f2cmin(i__2,*n); +/* Computing MIN */ + i__2 = p + 1; + mp = f2cmin(i__2,*m); + i__2 = *n - *l + p; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + r_cnjg(&q__1, &b[i__ + j * b_dim1]); + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + +/* Triangular part of B2 */ + + i__2 = p; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * t_dim1; + i__4 = i__ + (*n - *l + j) * b_dim1; + q__1.r = alpha.r * b[i__4].r - alpha.i * b[i__4].i, q__1.i = + alpha.r * b[i__4].i + alpha.i * b[i__4].r; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + ctrmv_("L", "N", "N", &p, &b[np * b_dim1 + 1], ldb, &t[i__ + t_dim1], + ldt); + +/* Rectangular part of B2 */ + + i__2 = i__ - 1 - p; + cgemv_("N", &i__2, l, &alpha, &b[mp + np * b_dim1], ldb, &b[i__ + np * + b_dim1], ldb, &c_b1, &t[i__ + mp * t_dim1], ldt); + +/* B1 */ + + i__2 = i__ - 1; + i__3 = *n - *l; + cgemv_("N", &i__2, &i__3, &alpha, &b[b_offset], ldb, &b[i__ + b_dim1], + ldb, &c_b2, &t[i__ + t_dim1], ldt); + + +/* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * t_dim1; + r_cnjg(&q__1, &t[i__ + j * t_dim1]); + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + i__2 = i__ - 1; + ctrmv_("L", "C", "N", &i__2, &t[t_offset], ldt, &t[i__ + t_dim1], ldt); + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * t_dim1; + r_cnjg(&q__1, &t[i__ + j * t_dim1]); + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + i__2 = *n - *l + p; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + r_cnjg(&q__1, &b[i__ + j * b_dim1]); + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + +/* T(I,I) = tau(I) */ + + i__2 = i__ + i__ * t_dim1; + i__3 = i__ * t_dim1 + 1; + t[i__2].r = t[i__3].r, t[i__2].i = t[i__3].i; + i__2 = i__ * t_dim1 + 1; + t[i__2].r = 0.f, t[i__2].i = 0.f; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * t_dim1; + i__4 = j + i__ * t_dim1; + t[i__3].r = t[i__4].r, t[i__3].i = t[i__4].i; + i__3 = j + i__ * t_dim1; + t[i__3].r = 0.f, t[i__3].i = 0.f; + } + } + +/* End of CTPLQT2 */ + + return 0; +} /* ctplqt2_ */ + diff --git a/lapack-netlib/SRC/ctpmlqt.c b/lapack-netlib/SRC/ctpmlqt.c new file mode 100644 index 000000000..2029c54b0 --- /dev/null +++ b/lapack-netlib/SRC/ctpmlqt.c @@ -0,0 +1,771 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPMLQT */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, */ +/* A, LDA, B, LDB, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT */ +/* COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), */ +/* $ T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPMLQT applies a complex orthogonal matrix Q obtained from a */ +/* > "triangular-pentagonal" complex block reflector H to a general */ +/* > complex matrix C, which consists of two blocks A and B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size used for the storage of T. K >= MB >= 1. */ +/* > This must be the same value of MB used to generate T */ +/* > in DTPLQT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX array, dimension (LDV,K) */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > DTPLQT in B. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by DTPLQT, stored as a MB-by-K matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,N) if SIDE = 'L' or */ +/* > (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > Q*C or Q**H*C or C*Q or C*Q**H. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDC >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > Q*C or Q**H*C or C*Q or C*Q**H. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. */ +/* > LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array. The dimension of WORK is */ +/* > N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The columns of the pentagonal matrix V contain the elementary reflectors */ +/* > H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2: */ +/* > */ +/* > V = [V1] [V2]. */ +/* > */ +/* > */ +/* > The size of the trapezoidal block V2 is determined by the parameter L, */ +/* > where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L */ +/* > rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; */ +/* > if L=0, there is no trapezoidal block, hence V = V1 is rectangular. */ +/* > */ +/* > If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. */ +/* > [B] */ +/* > */ +/* > If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. */ +/* > */ +/* > The real orthogonal matrix Q is formed from V and T. */ +/* > */ +/* > If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. */ +/* > */ +/* > If TRANS='C' and SIDE='L', C is on exit replaced with Q**H * C. */ +/* > */ +/* > If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. */ +/* > */ +/* > If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**H. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctpmlqt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, integer *mb, complex *v, integer *ldv, + complex *t, integer *ldt, complex *a, integer *lda, complex *b, + integer *ldb, complex *work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, a_dim1, a_offset, b_dim1, b_offset, t_dim1, + t_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer ldaq; + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ib, lb, nb, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), ctprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + logical notran; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "C"); + notran = lsame_(trans, "N"); + + if (left) { + ldaq = f2cmax(1,*k); + } else if (right) { + ldaq = f2cmax(1,*m); + } + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*l < 0 || *l > *k) { + *info = -6; + } else if (*mb < 1 || *mb > *k && *k > 0) { + *info = -7; + } else if (*ldv < *k) { + *info = -9; + } else if (*ldt < *mb) { + *info = -11; + } else if (*lda < ldaq) { + *info = -13; + } else if (*ldb < f2cmax(1,*m)) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPMLQT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran) { + + i__1 = *k; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + nb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = 0; + } + ctprfb_("L", "C", "F", "R", &nb, n, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, &b[ + b_offset], ldb, &work[1], &ib); + } + + } else if (right && tran) { + + i__2 = *k; + i__1 = *mb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + ctprfb_("R", "N", "F", "R", m, &nb, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], lda, + &b[b_offset], ldb, &work[1], m); + } + + } else if (left && tran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *m - *l + i__ + ib - 1; + nb = f2cmin(i__2,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = 0; + } + ctprfb_("L", "N", "F", "R", &nb, n, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, &b[ + b_offset], ldb, &work[1], &ib); + } + + } else if (right && notran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__2,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + ctprfb_("R", "C", "F", "R", m, &nb, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], lda, + &b[b_offset], ldb, &work[1], m); + } + + } + + return 0; + +/* End of CTPMLQT */ + +} /* ctpmlqt_ */ + diff --git a/lapack-netlib/SRC/ctpmqrt.c b/lapack-netlib/SRC/ctpmqrt.c new file mode 100644 index 000000000..125996b07 --- /dev/null +++ b/lapack-netlib/SRC/ctpmqrt.c @@ -0,0 +1,791 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPMQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPMQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, */ +/* A, LDA, B, LDB, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT */ +/* COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPMQRT applies a complex orthogonal matrix Q obtained from a */ +/* > "triangular-pentagonal" complex block reflector H to a general */ +/* > complex matrix C, which consists of two blocks A and B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size used for the storage of T. K >= NB >= 1. */ +/* > This must be the same value of NB used to generate T */ +/* > in CTPQRT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX array, dimension (LDV,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CTPQRT in B. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by CTPQRT, stored as a NB-by-K matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,N) if SIDE = 'L' or */ +/* > (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > Q*C or Q**H*C or C*Q or C*Q**H. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDC >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > Q*C or Q**H*C or C*Q or C*Q**H. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. */ +/* > LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array. The dimension of WORK is */ +/* > N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. */ +/* > \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 complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The columns of the pentagonal matrix V contain the elementary reflectors */ +/* > H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2: */ +/* > */ +/* > V = [V1] */ +/* > [V2]. */ +/* > */ +/* > The size of the trapezoidal block V2 is determined by the parameter L, */ +/* > where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L */ +/* > rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; */ +/* > if L=0, there is no trapezoidal block, hence V = V1 is rectangular. */ +/* > */ +/* > If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. */ +/* > [B] */ +/* > */ +/* > If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. */ +/* > */ +/* > The complex orthogonal matrix Q is formed from V and T. */ +/* > */ +/* > If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. */ +/* > */ +/* > If TRANS='C' and SIDE='L', C is on exit replaced with Q**H * C. */ +/* > */ +/* > If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. */ +/* > */ +/* > If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**H. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctpmqrt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, integer *nb, complex *v, integer *ldv, + complex *t, integer *ldt, complex *a, integer *lda, complex *b, + integer *ldb, complex *work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, a_dim1, a_offset, b_dim1, b_offset, t_dim1, + t_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer ldaq; + logical left, tran; + integer ldvq, i__; + extern logical lsame_(char *, char *); + logical right; + integer ib, lb, mb, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), ctprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + logical notran; + + +/* -- 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 */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "C"); + notran = lsame_(trans, "N"); + + if (left) { + ldvq = f2cmax(1,*m); + ldaq = f2cmax(1,*k); + } else if (right) { + ldvq = f2cmax(1,*n); + ldaq = f2cmax(1,*m); + } + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*l < 0 || *l > *k) { + *info = -6; + } else if (*nb < 1 || *nb > *k && *k > 0) { + *info = -7; + } else if (*ldv < ldvq) { + *info = -9; + } else if (*ldt < *nb) { + *info = -11; + } else if (*lda < ldaq) { + *info = -13; + } else if (*ldb < f2cmax(1,*m)) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPMQRT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && tran) { + + i__1 = *k; + 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 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + ctprfb_("L", "C", "F", "C", &mb, n, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, & + b[b_offset], ldb, &work[1], &ib); + } + + } else if (right && notran) { + + i__2 = *k; + 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 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + mb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *n + *l - i__ + 1; + } + ctprfb_("R", "N", "F", "C", m, &mb, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], + lda, &b[b_offset], ldb, &work[1], m); + } + + } else if (left && notran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__2,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + ctprfb_("L", "N", "F", "C", &mb, n, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, & + b[b_offset], ldb, &work[1], &ib); + } + + } else if (right && tran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *n - *l + i__ + ib - 1; + mb = f2cmin(i__2,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *n + *l - i__ + 1; + } + ctprfb_("R", "C", "F", "C", m, &mb, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], + lda, &b[b_offset], ldb, &work[1], m); + } + + } + + return 0; + +/* End of CTPMQRT */ + +} /* ctpmqrt_ */ + diff --git a/lapack-netlib/SRC/ctpqrt.c b/lapack-netlib/SRC/ctpqrt.c new file mode 100644 index 000000000..6c67b95df --- /dev/null +++ b/lapack-netlib/SRC/ctpqrt.c @@ -0,0 +1,682 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L, NB */ +/* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPQRT computes a blocked QR factorization of a complex */ +/* > "triangular-pentagonal" matrix C, which is composed of a */ +/* > triangular block A and pentagonal block B, using the compact */ +/* > WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of the */ +/* > triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the upper trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The 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 upper triangular N-by-N matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first M-L rows */ +/* > are rectangular, and the last L rows are upper trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > The upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (NB*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 */ +/* > */ +/* > The input matrix C is a (N+M)-by-N matrix */ +/* > */ +/* > C = [ A ] */ +/* > [ B ] */ +/* > */ +/* > where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ] <- (M-L)-by-N rectangular */ +/* > [ B2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The upper trapezoidal matrix B2 consists of the first L rows of a */ +/* > N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is upper triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th column */ +/* > below the diagonal (of A) in the (N+M)-by-N input matrix C */ +/* > */ +/* > C = [ A ] <- upper triangular N-by-N */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ] <- identity, N-by-N */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > V = [ V1 ] <- (M-L)-by-N rectangular */ +/* > [ V2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The columns of V represent the vectors which define the H(i)'s. */ +/* > */ +/* > The number of blocks is B = ceiling(N/NB), where each */ +/* > block is of order NB except for the last block, which is of order */ +/* > IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB */ +/* > for the last block) T's are stored in the NB-by-N matrix T as */ +/* > */ +/* > T = [T1 T2 ... TB]. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctpqrt_(integer *m, integer *n, integer *l, integer *nb, + complex *a, integer *lda, complex *b, integer *ldb, complex *t, + integer *ldt, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, iinfo, ib, lb, mb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), ctprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *), ctpqrt2_(integer *, integer *, integer *, + complex *, 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 arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n) && f2cmin(*m,*n) >= 0) { + *info = -3; + } else if (*nb < 1 || *nb > *n && *n > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*m)) { + *info = -8; + } else if (*ldt < *nb) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPQRT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *n; + i__2 = *nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block */ + +/* Computing MIN */ + i__3 = *n - i__ + 1; + ib = f2cmin(i__3,*nb); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + + ctpqrt2_(&mb, &ib, &lb, &a[i__ + i__ * a_dim1], lda, &b[i__ * b_dim1 + + 1], ldb, &t[i__ * t_dim1 + 1], ldt, &iinfo); + +/* Update by applying H**H to B(:,I+IB:N) from the left */ + + if (i__ + ib <= *n) { + i__3 = *n - i__ - ib + 1; + ctprfb_("L", "C", "F", "C", &mb, &i__3, &ib, &lb, &b[i__ * b_dim1 + + 1], ldb, &t[i__ * t_dim1 + 1], ldt, &a[i__ + (i__ + ib) + * a_dim1], lda, &b[(i__ + ib) * b_dim1 + 1], ldb, &work[1] + , &ib); + } + } + return 0; + +/* End of CTPQRT */ + +} /* ctpqrt_ */ + diff --git a/lapack-netlib/SRC/ctpqrt2.c b/lapack-netlib/SRC/ctpqrt2.c new file mode 100644 index 000000000..084e75a93 --- /dev/null +++ b/lapack-netlib/SRC/ctpqrt2.c @@ -0,0 +1,754 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which +is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPQRT2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L */ +/* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPQRT2 computes a QR factorization of a complex "triangular-pentagonal" */ +/* > matrix C, which is composed of a triangular block A and pentagonal block B, */ +/* > using the compact WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of */ +/* > the triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the upper trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the upper triangular N-by-N matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first M-L rows */ +/* > are rectangular, and the last L rows are upper trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > The N-by-N upper triangular factor T of the block reflector. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= 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 */ +/* > */ +/* > The input matrix C is a (N+M)-by-N matrix */ +/* > */ +/* > C = [ A ] */ +/* > [ B ] */ +/* > */ +/* > where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ] <- (M-L)-by-N rectangular */ +/* > [ B2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The upper trapezoidal matrix B2 consists of the first L rows of a */ +/* > N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is upper triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th column */ +/* > below the diagonal (of A) in the (N+M)-by-N input matrix C */ +/* > */ +/* > C = [ A ] <- upper triangular N-by-N */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ] <- identity, N-by-N */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > V = [ V1 ] <- (M-L)-by-N rectangular */ +/* > [ V2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The columns of V represent the vectors which define the H(i)'s. */ +/* > The (M+N)-by-(M+N) block reflector H is then given by */ +/* > */ +/* > H = I - W * T * W**H */ +/* > */ +/* > where W**H is the conjugate transpose of W and T is the upper triangular */ +/* > factor of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctpqrt2_(integer *m, integer *n, integer *l, complex *a, + integer *lda, complex *b, integer *ldb, complex *t, integer *ldt, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3, i__4; + complex q__1, q__2, q__3; + + /* Local variables */ + integer i__, j, p; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *); + complex alpha; + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), ctrmv_(char *, char *, char *, integer *, + complex *, integer *, complex *, integer *); + integer mp, np; + extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, + integer *, complex *), 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 arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n)) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*m)) { + *info = -7; + } else if (*ldt < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPQRT2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(I) to annihilate B(:,I) */ + + p = *m - *l + f2cmin(*l,i__); + i__2 = p + 1; + clarfg_(&i__2, &a[i__ + i__ * a_dim1], &b[i__ * b_dim1 + 1], &c__1, & + t[i__ + t_dim1]); + if (i__ < *n) { + +/* W(1:N-I) := C(I:M,I+1:N)**H * C(I:M,I) [use W = T(:,N)] */ + + i__2 = *n - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + *n * t_dim1; + r_cnjg(&q__1, &a[i__ + (i__ + j) * a_dim1]); + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + i__2 = *n - i__; + cgemv_("C", &p, &i__2, &c_b1, &b[(i__ + 1) * b_dim1 + 1], ldb, &b[ + i__ * b_dim1 + 1], &c__1, &c_b1, &t[*n * t_dim1 + 1], & + c__1); + +/* C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)**H */ + + r_cnjg(&q__2, &t[i__ + t_dim1]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = *n - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + (i__ + j) * a_dim1; + i__4 = i__ + (i__ + j) * a_dim1; + r_cnjg(&q__3, &t[j + *n * t_dim1]); + q__2.r = alpha.r * q__3.r - alpha.i * q__3.i, q__2.i = + alpha.r * q__3.i + alpha.i * q__3.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; + } + i__2 = *n - i__; + cgerc_(&p, &i__2, &alpha, &b[i__ * b_dim1 + 1], &c__1, &t[*n * + t_dim1 + 1], &c__1, &b[(i__ + 1) * b_dim1 + 1], ldb); + } + } + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T(1:I-1,I) := C(I:M,1:I-1)**H * (alpha * C(I:M,I)) */ + + i__2 = i__ + t_dim1; + q__1.r = -t[i__2].r, q__1.i = -t[i__2].i; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + t[i__3].r = 0.f, t[i__3].i = 0.f; + } +/* Computing MIN */ + i__2 = i__ - 1; + p = f2cmin(i__2,*l); +/* Computing MIN */ + i__2 = *m - *l + 1; + mp = f2cmin(i__2,*m); +/* Computing MIN */ + i__2 = p + 1; + np = f2cmin(i__2,*n); + +/* Triangular part of B2 */ + + i__2 = p; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = *m - *l + j + i__ * b_dim1; + q__1.r = alpha.r * b[i__4].r - alpha.i * b[i__4].i, q__1.i = + alpha.r * b[i__4].i + alpha.i * b[i__4].r; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + ctrmv_("U", "C", "N", &p, &b[mp + b_dim1], ldb, &t[i__ * t_dim1 + 1], + &c__1); + +/* Rectangular part of B2 */ + + i__2 = i__ - 1 - p; + cgemv_("C", l, &i__2, &alpha, &b[mp + np * b_dim1], ldb, &b[mp + i__ * + b_dim1], &c__1, &c_b2, &t[np + i__ * t_dim1], &c__1); + +/* B1 */ + + i__2 = *m - *l; + i__3 = i__ - 1; + cgemv_("C", &i__2, &i__3, &alpha, &b[b_offset], ldb, &b[i__ * b_dim1 + + 1], &c__1, &c_b1, &t[i__ * t_dim1 + 1], &c__1); + +/* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) */ + + i__2 = i__ - 1; + ctrmv_("U", "N", "N", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], + &c__1); + +/* T(I,I) = tau(I) */ + + i__2 = i__ + i__ * t_dim1; + i__3 = i__ + t_dim1; + t[i__2].r = t[i__3].r, t[i__2].i = t[i__3].i; + i__2 = i__ + t_dim1; + t[i__2].r = 0.f, t[i__2].i = 0.f; + } + +/* End of CTPQRT2 */ + + return 0; +} /* ctpqrt2_ */ + diff --git a/lapack-netlib/SRC/ctprfb.c b/lapack-netlib/SRC/ctprfb.c new file mode 100644 index 000000000..88e292832 --- /dev/null +++ b/lapack-netlib/SRC/ctprfb.c @@ -0,0 +1,1505 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex + matrix, which is composed of two blocks. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPRFB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, */ +/* V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) */ + +/* CHARACTER DIRECT, SIDE, STOREV, TRANS */ +/* INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N */ +/* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), */ +/* $ V( LDV, * ), WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPRFB applies a complex "triangular-pentagonal" block reflector H or its */ +/* > conjugate transpose H**H to a complex matrix C, which is composed of two */ +/* > blocks A and B, either from the left or right. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply H or H**H from the Left */ +/* > = 'R': apply H or H**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply H (No transpose) */ +/* > = 'C': apply H**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Indicates how H is formed from a product of elementary */ +/* > reflectors */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Indicates how the vectors which define the elementary */ +/* > reflectors are stored: */ +/* > = 'C': Columns */ +/* > = 'R': Rows */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the matrix T, i.e. the number of elementary */ +/* > reflectors whose product defines the block reflector. */ +/* > K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,M) if STOREV = 'R' and SIDE = 'L' */ +/* > (LDV,N) if STOREV = 'R' and SIDE = 'R' */ +/* > The pentagonal matrix V, which contains the elementary reflectors */ +/* > H(1), H(2), ..., H(K). See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C' and SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if STOREV = 'C' and SIDE = 'R', LDV >= f2cmax(1,N); */ +/* > if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,K) */ +/* > The triangular K-by-K matrix T in the representation of the */ +/* > block reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. */ +/* > LDT >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > H*C or H**H*C or C*H or C*H**H. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > H*C or H**H*C or C*H or C*H**H. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. */ +/* > LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (LDWORK,N) if SIDE = 'L', */ +/* > (LDWORK,K) if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > If SIDE = 'L', LDWORK >= K; */ +/* > if SIDE = 'R', LDWORK >= M. */ +/* > \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 */ +/* > */ +/* > The matrix C is a composite matrix formed from blocks A and B. */ +/* > The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, */ +/* > and if SIDE = 'L', A is of size K-by-N. */ +/* > */ +/* > If SIDE = 'R' and DIRECT = 'F', C = [A B]. */ +/* > */ +/* > If SIDE = 'L' and DIRECT = 'F', C = [A] */ +/* > [B]. */ +/* > */ +/* > If SIDE = 'R' and DIRECT = 'B', C = [B A]. */ +/* > */ +/* > If SIDE = 'L' and DIRECT = 'B', C = [B] */ +/* > [A]. */ +/* > */ +/* > The pentagonal matrix V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2. The size of the trapezoidal block is determined by */ +/* > the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; */ +/* > if L=0, there is no trapezoidal block, thus V = V1 is rectangular. */ +/* > */ +/* > If DIRECT = 'F' and STOREV = 'C': V = [V1] */ +/* > [V2] */ +/* > - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) */ +/* > */ +/* > If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] */ +/* > */ +/* > - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) */ +/* > */ +/* > If DIRECT = 'B' and STOREV = 'C': V = [V2] */ +/* > [V1] */ +/* > - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) */ +/* > */ +/* > If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] */ +/* > */ +/* > - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) */ +/* > */ +/* > If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. */ +/* > */ +/* > If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. */ +/* > */ +/* > If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. */ +/* > */ +/* > If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctprfb_(char *side, char *trans, char *direct, char * + storev, integer *m, integer *n, integer *k, integer *l, complex *v, + integer *ldv, complex *t, integer *ldt, complex *a, integer *lda, + complex *b, integer *ldb, complex *work, integer *ldwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, v_dim1, + v_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1; + + /* Local variables */ + logical left, backward; + integer i__, j; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + extern logical lsame_(char *, char *); + logical right; + extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer kp, mp, np; + logical column, row, forward; + + +/* -- 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 */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0 || *k <= 0 || *l < 0) { + return 0; + } + + if (lsame_(storev, "C")) { + column = TRUE_; + row = FALSE_; + } else if (lsame_(storev, "R")) { + column = FALSE_; + row = TRUE_; + } else { + column = FALSE_; + row = FALSE_; + } + + if (lsame_(side, "L")) { + left = TRUE_; + right = FALSE_; + } else if (lsame_(side, "R")) { + left = FALSE_; + right = TRUE_; + } else { + left = FALSE_; + right = FALSE_; + } + + if (lsame_(direct, "F")) { + forward = TRUE_; + backward = FALSE_; + } else if (lsame_(direct, "B")) { + forward = FALSE_; + backward = TRUE_; + } else { + forward = FALSE_; + backward = FALSE_; + } + +/* --------------------------------------------------------------------------- */ + + if (column && forward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I ] (K-by-K) */ +/* [ V ] (M-by-K) */ + +/* Form H C or H**H C where C = [ A ] (K-by-N) */ +/* [ B ] (M-by-N) */ + +/* H = I - W T W**H or H**H = I - W T**H W**H */ + +/* A = A - T (A + V**H B) or A = A - T**H (A + V**H B) */ +/* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *m - *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = *m - *l + i__ + j * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + ctrmm_("L", "U", "C", "N", l, n, &c_b1, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *m - *l; + cgemm_("C", "N", l, n, &i__1, &c_b1, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b1, &work[work_offset], ldwork); + i__1 = *k - *l; + cgemm_("C", "N", &i__1, n, m, &c_b1, &v[kp * v_dim1 + 1], ldv, &b[ + b_offset], ldb, &c_b2, &work[kp + work_dim1], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("L", "U", trans, "N", k, n, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *m - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &i__1, n, k, &q__1, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b1, &b[b_offset], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", l, n, &i__1, &q__1, &v[mp + kp * v_dim1], ldv, &work[ + kp + work_dim1], ldwork, &c_b1, &b[mp + b_dim1], ldb); + ctrmm_("L", "U", "N", "N", l, n, &c_b1, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *l + i__ + j * b_dim1; + i__4 = *m - *l + i__ + j * b_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && forward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I ] (K-by-K) */ +/* [ V ] (N-by-K) */ + +/* Form C H or C H**H where C = [ A B ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W T W**H or H**H = I - W T**H W**H */ + +/* A = A - (A + B V) T or A = A - (A + B V) T**H */ +/* B = B - (A + B V) T V**H or B = B - (A + B V) T**H V**H */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *n - *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + (*n - *l + j) * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + ctrmm_("R", "U", "N", "N", m, l, &c_b1, &v[np + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *n - *l; + cgemm_("N", "N", m, l, &i__1, &c_b1, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b1, &work[work_offset], ldwork); + i__1 = *k - *l; + cgemm_("N", "N", m, &i__1, n, &c_b1, &b[b_offset], ldb, &v[kp * + v_dim1 + 1], ldv, &c_b2, &work[kp * work_dim1 + 1], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("R", "U", trans, "N", m, k, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *n - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b1, &b[b_offset], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, l, &i__1, &q__1, &work[kp * work_dim1 + 1], + ldwork, &v[np + kp * v_dim1], ldv, &c_b1, &b[np * b_dim1 + 1], + ldb); + ctrmm_("R", "U", "C", "N", m, l, &c_b1, &v[np + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *l + j) * b_dim1; + i__4 = i__ + (*n - *l + j) * b_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && backward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V ] (M-by-K) */ +/* [ I ] (K-by-K) */ + +/* Form H C or H**H C where C = [ B ] (M-by-N) */ +/* [ A ] (K-by-N) */ + +/* H = I - W T W**H or H**H = I - W T**H W**H */ + +/* A = A - T (A + V**H B) or A = A - T**H (A + V**H B) */ +/* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *k - *l + i__ + j * work_dim1; + i__4 = i__ + j * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + + ctrmm_("L", "L", "C", "N", l, n, &c_b1, &v[kp * v_dim1 + 1], ldv, & + work[kp + work_dim1], ldwork); + i__1 = *m - *l; + cgemm_("C", "N", l, n, &i__1, &c_b1, &v[mp + kp * v_dim1], ldv, &b[mp + + b_dim1], ldb, &c_b1, &work[kp + work_dim1], ldwork); + i__1 = *k - *l; + cgemm_("C", "N", &i__1, n, m, &c_b1, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b2, &work[work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("L", "L", trans, "N", k, n, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *m - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", &i__1, n, k, &q__1, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork, &c_b1, &b[mp + b_dim1], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", l, n, &i__1, &q__1, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b1, &b[b_offset], ldb); + ctrmm_("L", "L", "N", "N", l, n, &c_b1, &v[kp * v_dim1 + 1], ldv, & + work[kp + work_dim1], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = *k - *l + i__ + j * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && backward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V ] (N-by-K) */ +/* [ I ] (K-by-K) */ + +/* Form C H or C H**H where C = [ B A ] (B is M-by-N, A is M-by-K) */ + +/* H = I - W T W**H or H**H = I - W T**H W**H */ + +/* A = A - (A + B V) T or A = A - (A + B V) T**H */ +/* B = B - (A + B V) T V**H or B = B - (A + B V) T**H V**H */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*k - *l + j) * work_dim1; + i__4 = i__ + j * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + ctrmm_("R", "L", "N", "N", m, l, &c_b1, &v[kp * v_dim1 + 1], ldv, & + work[kp * work_dim1 + 1], ldwork); + i__1 = *n - *l; + cgemm_("N", "N", m, l, &i__1, &c_b1, &b[np * b_dim1 + 1], ldb, &v[np + + kp * v_dim1], ldv, &c_b1, &work[kp * work_dim1 + 1], ldwork); + i__1 = *k - *l; + cgemm_("N", "N", m, &i__1, n, &c_b1, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b2, &work[work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("R", "L", trans, "N", m, k, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *n - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v[ + np + v_dim1], ldv, &c_b1, &b[np * b_dim1 + 1], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "C", m, l, &i__1, &q__1, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b1, &b[b_offset], ldb); + ctrmm_("R", "L", "C", "N", m, l, &c_b1, &v[kp * v_dim1 + 1], ldv, & + work[kp * work_dim1 + 1], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + (*k - *l + j) * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && forward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I V ] ( I is K-by-K, V is K-by-M ) */ + +/* Form H C or H**H C where C = [ A ] (K-by-N) */ +/* [ B ] (M-by-N) */ + +/* H = I - W**H T W or H**H = I - W**H T**H W */ + +/* A = A - T (A + V B) or A = A - T**H (A + V B) */ +/* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *m - *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = *m - *l + i__ + j * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + ctrmm_("L", "L", "N", "N", l, n, &c_b1, &v[mp * v_dim1 + 1], ldv, & + work[work_offset], ldb); + i__1 = *m - *l; + cgemm_("N", "N", l, n, &i__1, &c_b1, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b1, &work[work_offset], ldwork); + i__1 = *k - *l; + cgemm_("N", "N", &i__1, n, m, &c_b1, &v[kp + v_dim1], ldv, &b[ + b_offset], ldb, &c_b2, &work[kp + work_dim1], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("L", "U", trans, "N", k, n, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *m - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &i__1, n, k, &q__1, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b1, &b[b_offset], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", l, n, &i__1, &q__1, &v[kp + mp * v_dim1], ldv, &work[ + kp + work_dim1], ldwork, &c_b1, &b[mp + b_dim1], ldb); + ctrmm_("L", "L", "C", "N", l, n, &c_b1, &v[mp * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *l + i__ + j * b_dim1; + i__4 = *m - *l + i__ + j * b_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && forward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I V ] ( I is K-by-K, V is K-by-N ) */ + +/* Form C H or C H**H where C = [ A B ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W**H T W or H**H = I - W**H T**H W */ + +/* A = A - (A + B V**H) T or A = A - (A + B V**H) T**H */ +/* B = B - (A + B V**H) T V or B = B - (A + B V**H) T**H V */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *n - *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + (*n - *l + j) * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + ctrmm_("R", "L", "C", "N", m, l, &c_b1, &v[np * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *n - *l; + cgemm_("N", "C", m, l, &i__1, &c_b1, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b1, &work[work_offset], ldwork); + i__1 = *k - *l; + cgemm_("N", "C", m, &i__1, n, &c_b1, &b[b_offset], ldb, &v[kp + + v_dim1], ldv, &c_b2, &work[kp * work_dim1 + 1], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("R", "U", trans, "N", m, k, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *n - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b1, &b[b_offset], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, l, &i__1, &q__1, &work[kp * work_dim1 + 1], + ldwork, &v[kp + np * v_dim1], ldv, &c_b1, &b[np * b_dim1 + 1], + ldb); + ctrmm_("R", "L", "N", "N", m, l, &c_b1, &v[np * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *l + j) * b_dim1; + i__4 = i__ + (*n - *l + j) * b_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && backward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V I ] ( I is K-by-K, V is K-by-M ) */ + +/* Form H C or H**H C where C = [ B ] (M-by-N) */ +/* [ A ] (K-by-N) */ + +/* H = I - W**H T W or H**H = I - W**H T**H W */ + +/* A = A - T (A + V B) or A = A - T**H (A + V B) */ +/* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *k - *l + i__ + j * work_dim1; + i__4 = i__ + j * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + ctrmm_("L", "U", "N", "N", l, n, &c_b1, &v[kp + v_dim1], ldv, &work[ + kp + work_dim1], ldwork); + i__1 = *m - *l; + cgemm_("N", "N", l, n, &i__1, &c_b1, &v[kp + mp * v_dim1], ldv, &b[mp + + b_dim1], ldb, &c_b1, &work[kp + work_dim1], ldwork); + i__1 = *k - *l; + cgemm_("N", "N", &i__1, n, m, &c_b1, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b2, &work[work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("L", "L ", trans, "N", k, n, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *m - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", &i__1, n, k, &q__1, &v[mp * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, &c_b1, &b[mp + b_dim1], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("C", "N", l, n, &i__1, &q__1, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b1, &b[b_offset], ldb); + ctrmm_("L", "U", "C", "N", l, n, &c_b1, &v[kp + v_dim1], ldv, &work[ + kp + work_dim1], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = *k - *l + i__ + j * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && backward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V I ] ( I is K-by-K, V is K-by-N ) */ + +/* Form C H or C H**H where C = [ B A ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W**H T W or H**H = I - W**H T**H W */ + +/* A = A - (A + B V**H) T or A = A - (A + B V**H) T**H */ +/* B = B - (A + B V**H) T V or B = B - (A + B V**H) T**H V */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*k - *l + j) * work_dim1; + i__4 = i__ + j * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; + } + } + ctrmm_("R", "U", "C", "N", m, l, &c_b1, &v[kp + v_dim1], ldv, &work[ + kp * work_dim1 + 1], ldwork); + i__1 = *n - *l; + cgemm_("N", "C", m, l, &i__1, &c_b1, &b[np * b_dim1 + 1], ldb, &v[kp + + np * v_dim1], ldv, &c_b1, &work[kp * work_dim1 + 1], ldwork); + i__1 = *k - *l; + cgemm_("N", "C", m, &i__1, n, &c_b1, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b2, &work[work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + j * work_dim1; + i__5 = i__ + j * a_dim1; + q__1.r = work[i__4].r + a[i__5].r, q__1.i = work[i__4].i + a[ + i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; + } + } + + ctrmm_("R", "L", trans, "N", m, k, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = a[i__4].r - work[i__5].r, q__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + + i__1 = *n - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v[ + np * v_dim1 + 1], ldv, &c_b1, &b[np * b_dim1 + 1], ldb); + i__1 = *k - *l; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, l, &i__1, &q__1, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b1, &b[b_offset], ldb); + ctrmm_("R", "U", "N", "N", m, l, &c_b1, &v[kp + v_dim1], ldv, &work[ + kp * work_dim1 + 1], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + (*k - *l + j) * work_dim1; + q__1.r = b[i__4].r - work[i__5].r, q__1.i = b[i__4].i - work[ + i__5].i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + } + + } + + return 0; + +/* End of CTPRFB */ + +} /* ctprfb_ */ + diff --git a/lapack-netlib/SRC/ctprfs.c b/lapack-netlib/SRC/ctprfs.c new file mode 100644 index 000000000..5030e8948 --- /dev/null +++ b/lapack-netlib/SRC/ctprfs.c @@ -0,0 +1,1002 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, */ +/* FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular packed */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by CTPTRS or some other */ +/* > means before entering this routine. CTPRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \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 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. */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 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] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > The 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 */ + +/* 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 ctprfs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, complex *ap, 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 *), ctpmv_(char *, char *, char *, + integer *, complex *, complex *, integer *); + logical upper; + extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, + complex *, complex *, integer *), clacn2_( + integer *, complex *, complex *, real *, integer *, integer *); + integer kc; + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transn[1], transt[1]; + logical nounit; + 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; + 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"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + 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 (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldx < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPRFS", &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; + } + + if (notran) { + *(unsigned char *)transn = 'N'; + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transn = 'C'; + *(unsigned char *)transt = 'N'; + } + +/* 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) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); + ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); + q__1.r = -1.f, q__1.i = 0.f; + caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + 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)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = kc + i__ - 1; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + ( + r__2 = r_imag(&ap[kc + i__ - 1]), abs( + r__2))) * xk; +/* L30: */ + } + kc += k; +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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 = kc + i__ - 1; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + ( + r__2 = r_imag(&ap[kc + i__ - 1]), abs( + r__2))) * xk; +/* L50: */ + } + rwork[k] += xk; + kc += k; +/* L60: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + i__4 = kc + i__ - k; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + ( + r__2 = r_imag(&ap[kc + i__ - k]), abs( + r__2))) * xk; +/* L70: */ + } + kc = kc + *n - k + 1; +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = kc + i__ - k; + rwork[i__] += ((r__1 = ap[i__4].r, abs(r__1)) + ( + r__2 = r_imag(&ap[kc + i__ - k]), abs( + r__2))) * xk; +/* L90: */ + } + rwork[k] += xk; + kc = kc + *n - k + 1; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**H)*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = kc + i__ - 1; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[kc + i__ - 1]), abs(r__2))) * ( + (r__3 = x[i__5].r, abs(r__3)) + (r__4 = + r_imag(&x[i__ + j * x_dim1]), abs(r__4))); +/* L110: */ + } + rwork[k] += s; + kc += k; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * x_dim1; + s = (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 = kc + i__ - 1; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[kc + i__ - 1]), abs(r__2))) * ( + (r__3 = x[i__5].r, abs(r__3)) + (r__4 = + r_imag(&x[i__ + j * x_dim1]), abs(r__4))); +/* L130: */ + } + rwork[k] += s; + kc += k; +/* L140: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + i__4 = kc + i__ - k; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[kc + i__ - k]), abs(r__2))) * ( + (r__3 = x[i__5].r, abs(r__3)) + (r__4 = + r_imag(&x[i__ + j * x_dim1]), abs(r__4))); +/* L150: */ + } + rwork[k] += s; + kc = kc + *n - k + 1; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * x_dim1; + s = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[ + k + j * x_dim1]), abs(r__2)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = kc + i__ - k; + i__5 = i__ + j * x_dim1; + s += ((r__1 = ap[i__4].r, abs(r__1)) + (r__2 = + r_imag(&ap[kc + i__ - k]), abs(r__2))) * ( + (r__3 = x[i__5].r, abs(r__3)) + (r__4 = + r_imag(&x[i__ + j * x_dim1]), abs(r__4))); +/* L170: */ + } + rwork[k] += s; + kc = kc + *n - k + 1; +/* L180: */ + } + } + } + } + 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); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (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; + } +/* L200: */ + } + + kase = 0; +L210: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**H). */ + + ctpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1); + 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; +/* L220: */ + } + } else { + +/* Multiply by inv(op(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; +/* L230: */ + } + ctpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1); + } + goto L210; + } + +/* 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); +/* L240: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of CTPRFS */ + +} /* ctprfs_ */ + diff --git a/lapack-netlib/SRC/ctptri.c b/lapack-netlib/SRC/ctptri.c new file mode 100644 index 000000000..d08f5172f --- /dev/null +++ b/lapack-netlib/SRC/ctptri.c @@ -0,0 +1,660 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, N */ +/* COMPLEX AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPTRI computes the inverse of a complex upper or lower triangular */ +/* > matrix A stored in packed format. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \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 triangular matrix A, stored */ +/* > 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. */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same packed 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, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can 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 */ +/* > */ +/* > A triangular matrix A can be transferred to packed storage using one */ +/* > of the following program segments: */ +/* > */ +/* > UPLO = 'U': UPLO = 'L': */ +/* > */ +/* > JC = 1 JC = 1 */ +/* > DO 2 J = 1, N DO 2 J = 1, N */ +/* > DO 1 I = 1, J DO 1 I = J, N */ +/* > AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */ +/* > 1 CONTINUE 1 CONTINUE */ +/* > JC = JC + J JC = JC + N - J + 1 */ +/* > 2 CONTINUE 2 CONTINUE */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctptri_(char *uplo, char *diag, integer *n, complex *ap, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + complex q__1; + + /* Local variables */ + integer j; + extern /* Subroutine */ int cscal_(integer *, complex *, 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 xerbla_(char *, integer *, ftnlen); + integer jclast; + logical nounit; + complex 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"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + if (upper) { + jj = 0; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + jj += *info; + i__2 = jj; + if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { + return 0; + } +/* L10: */ + } + } else { + jj = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = jj; + if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { + return 0; + } + jj = jj + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + i__2 = jc + j - 1; + c_div(&q__1, &c_b1, &ap[jc + j - 1]); + ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; + i__2 = jc + j - 1; + q__1.r = -ap[i__2].r, q__1.i = -ap[i__2].i; + ajj.r = q__1.r, ajj.i = q__1.i; + } else { + q__1.r = -1.f, q__1.i = 0.f; + ajj.r = q__1.r, ajj.i = q__1.i; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + ctpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & + c__1); + i__2 = j - 1; + cscal_(&i__2, &ajj, &ap[jc], &c__1); + jc += j; +/* L30: */ + } + + } else { + +/* Compute inverse of lower triangular matrix. */ + + jc = *n * (*n + 1) / 2; + for (j = *n; j >= 1; --j) { + if (nounit) { + i__1 = jc; + c_div(&q__1, &c_b1, &ap[jc]); + ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; + i__1 = jc; + q__1.r = -ap[i__1].r, q__1.i = -ap[i__1].i; + ajj.r = q__1.r, ajj.i = q__1.i; + } else { + q__1.r = -1.f, q__1.i = 0.f; + ajj.r = q__1.r, ajj.i = q__1.i; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + ctpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ + jc + 1], &c__1); + i__1 = *n - j; + cscal_(&i__1, &ajj, &ap[jc + 1], &c__1); + } + jclast = jc; + jc = jc - *n + j - 2; +/* L40: */ + } + } + + return 0; + +/* End of CTPTRI */ + +} /* ctptri_ */ + diff --git a/lapack-netlib/SRC/ctptrs.c b/lapack-netlib/SRC/ctptrs.c new file mode 100644 index 000000000..4e6d6b5c7 --- /dev/null +++ b/lapack-netlib/SRC/ctptrs.c @@ -0,0 +1,628 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* COMPLEX AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B, A**T * X = B, or A**H * X = B, */ +/* > */ +/* > where A is a triangular matrix of order N stored in packed format, */ +/* > and B is an N-by-NRHS matrix. A check is made to verify that A is */ +/* > nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \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 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)*(2*n-j)/2) = A(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, if INFO = 0, 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 */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the */ +/* > solutions X have 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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, + complex *, complex *, integer *); + integer jc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nounit; + + +/* -- 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"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = jc + *info - 1; + if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { + return 0; + } + jc += *info; +/* L10: */ + } + } else { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = jc; + if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { + return 0; + } + jc = jc + *n - *info + 1; +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * x = b, A**T * x = b, or A**H * x = b. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ctpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of CTPTRS */ + +} /* ctptrs_ */ + diff --git a/lapack-netlib/SRC/ctpttf.c b/lapack-netlib/SRC/ctpttf.c new file mode 100644 index 000000000..0667c10b0 --- /dev/null +++ b/lapack-netlib/SRC/ctpttf.c @@ -0,0 +1,996 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full +packed format (TF). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPTTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N */ +/* COMPLEX AP( 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPTTF copies a triangular matrix A from standard packed format (TP) */ +/* > to rectangular full packed format (TF). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF in Normal format is wanted; */ +/* > = 'C': ARF in Conjugate-transpose format is wanted. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \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 ), */ +/* > On entry, 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[out] ARF */ +/* > \verbatim */ +/* > ARF is COMPLEX array, dimension ( N*(N+1)/2 ), */ +/* > On exit, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \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 ctpttf_(char *transr, char *uplo, integer *n, complex * + ap, complex *arf, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + complex q__1; + + /* Local variables */ + integer i__, j, k; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, jp, js, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer lda, ijp; + + +/* -- 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_("CTPTTF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + arf[0].r = ap[0].r, arf[0].i = ap[0].i; + } else { + r_cnjg(&q__1, ap); + arf[0].r = q__1.r, arf[0].i = q__1.i; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + lda = *n + 1; + } else { + nisodd = TRUE_; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* 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); lda = n */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + i__3 = ij; + i__4 = ijp; + arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + i__3 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ijp; + } + } + + } 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) */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + i__3 = ij; + i__4 = ijp; + arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i; + ++ijp; + } + js += lda; + } + + } + + } 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 */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= + i__2; ij += i__3) { + i__4 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__4].r = q__1.r, arf[i__4].i = q__1.i; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ij; + i__4 = ijp; + arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i; + ++ijp; + } + js = js + lda + 1; + } + + } 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 */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ij; + i__4 = ijp; + arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + i__4 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__4].r = q__1.r, arf[i__4].i = q__1.i; + ++ijp; + } + } + + } + + } + + } 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) */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + i__3 = ij; + i__4 = ijp; + arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + i__3 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ijp; + } + } + + } 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) */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + i__3 = ij; + i__4 = ijp; + arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i; + ++ijp; + } + js += lda; + } + + } + + } 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 */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : + ij <= i__2; ij += i__3) { + i__4 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__4].r = q__1.r, arf[i__4].i = q__1.i; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ij; + i__4 = ijp; + arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i; + ++ijp; + } + js = js + lda + 1; + } + + } 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 */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + i__2 = ij; + i__4 = ijp; + arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + i__4 = ij; + r_cnjg(&q__1, &ap[ijp]); + arf[i__4].r = q__1.r, arf[i__4].i = q__1.i; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of CTPTTF */ + +} /* ctpttf_ */ + diff --git a/lapack-netlib/SRC/ctpttr.c b/lapack-netlib/SRC/ctpttr.c new file mode 100644 index 000000000..ccd106145 --- /dev/null +++ b/lapack-netlib/SRC/ctpttr.c @@ -0,0 +1,571 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full for +mat (TR). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTPTTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N, LDA */ +/* COMPLEX A( LDA, * ), AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTPTTR copies a triangular matrix A from standard packed format (TP) */ +/* > to standard full format (TR). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular. */ +/* > = 'L': A is lower triangular. */ +/* > \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 ), */ +/* > On entry, 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[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > On exit, the triangular 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[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 ctpttr_(char *uplo, integer *n, complex *ap, 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__, j, k; + extern logical lsame_(char *, char *); + 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 */ + --ap; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTPTTR", &i__1, (ftnlen)6); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + i__3 = i__ + j * a_dim1; + i__4 = k; + a[i__3].r = ap[i__4].r, a[i__3].i = ap[i__4].i; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + i__3 = i__ + j * a_dim1; + i__4 = k; + a[i__3].r = ap[i__4].r, a[i__3].i = ap[i__4].i; + } + } + } + + + return 0; + +/* End of CTPTTR */ + +} /* ctpttr_ */ + diff --git a/lapack-netlib/SRC/ctrcon.c b/lapack-netlib/SRC/ctrcon.c new file mode 100644 index 000000000..c96159430 --- /dev/null +++ b/lapack-netlib/SRC/ctrcon.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 \b CTRCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, */ +/* RWORK, INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL RCOND */ +/* REAL RWORK( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRCON estimates the reciprocal of the condition number of a */ +/* > triangular matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \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[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \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 ctrcon_(char *norm, char *uplo, char *diag, integer *n, + complex *a, integer *lda, 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, kase1; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + real anorm; + logical upper; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + real xnorm; + integer ix; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern real clantr_(char *, char *, char *, integer *, integer *, complex + *, integer *, real *); + real ainvnm; + extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, + integer *, complex *, integer *, complex *, real *, real *, + integer *), csrscl_(integer *, + real *, complex *, integer *); + logical onenrm; + char normin[1]; + real smlnum; + logical nounit; + + +/* -- 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"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.f; + return 0; + } + + *rcond = 0.f; + smlnum = slamch_("Safe minimum") * (real) f2cmax(1,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = clantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &rwork[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.f) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.f; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + clatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], + lda, &work[1], &scale, &rwork[1], info); + } else { + +/* Multiply by inv(A**H). */ + + clatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[ + a_offset], lda, &work[1], &scale, &rwork[1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.f) { + ix = icamax_(n, &work[1], &c__1); + i__1 = ix; + xnorm = (r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& + work[ix]), abs(r__2)); + if (scale < xnorm * 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 / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of CTRCON */ + +} /* ctrcon_ */ + diff --git a/lapack-netlib/SRC/ctrevc.c b/lapack-netlib/SRC/ctrevc.c new file mode 100644 index 000000000..d8951e696 --- /dev/null +++ b/lapack-netlib/SRC/ctrevc.c @@ -0,0 +1,983 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTREVC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTREVC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, */ +/* LDVR, MM, M, WORK, RWORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* REAL RWORK( * ) */ +/* COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTREVC computes some or all of the right and/or left eigenvectors of */ +/* > a complex upper triangular matrix T. */ +/* > Matrices of this type are produced by the Schur factorization of */ +/* > a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of T corresponding */ +/* > to an eigenvalue w are defined by: */ +/* > */ +/* > T*x = w*x, (y**H)*T = w*(y**H) */ +/* > */ +/* > where y**H denotes the conjugate transpose of the vector y. */ +/* > The eigenvalues are not input to this routine, but are read directly */ +/* > from the diagonal of T. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ +/* > input matrix. If Q is the unitary factor that reduces a matrix A to */ +/* > Schur form T, then Q*X and Q*Y are the matrices of right and left */ +/* > eigenvectors of A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed using the matrices supplied in */ +/* > VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > as indicated by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ +/* > computed. */ +/* > The eigenvector corresponding to the j-th eigenvalue is */ +/* > computed if SELECT(j) = .TRUE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > The upper triangular matrix T. T is modified, but restored */ +/* > on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the unitary matrix Q of */ +/* > Schur vectors returned by CHSEQR). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VL, in the same order as their */ +/* > eigenvalues. */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1, and if */ +/* > SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Q (usually the unitary matrix Q of */ +/* > Schur vectors returned by CHSEQR). */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*X; */ +/* > if HOWMNY = 'S', the right eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VR, in the same order as their */ +/* > eigenvalues. */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1, and if */ +/* > SIDE = 'R' or 'B'; LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ +/* > is set to N. Each selected eigenvector occupies one */ +/* > column. */ +/* > \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 */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The algorithm used in this program is basically backward (forward) */ +/* > substitution, with scaling to make the the code robust against */ +/* > possible overflow. */ +/* > */ +/* > Each eigenvector is normalized so that the element of largest */ +/* > magnitude has magnitude 1; here the magnitude of a complex number */ +/* > (x,y) is taken to be |x| + |y|. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctrevc_(char *side, char *howmny, logical *select, + integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, + complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, + real *rwork, integer *info) +{ + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3, i__4, i__5; + real r__1, r__2, r__3; + complex q__1, q__2; + + /* Local variables */ + logical allv; + real unfl, ovfl, smin; + logical over; + integer i__, j, k; + real scale; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + real remax; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + logical leftv, bothv, somev; + integer ii, ki; + extern /* Subroutine */ int slabad_(real *, real *); + integer is; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen), clatrs_(char *, char *, + char *, char *, integer *, complex *, integer *, complex *, real * + , real *, integer *); + extern real scasum_(integer *, complex *, integer *); + logical rightv; + real smlnum, ulp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --rwork; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors. */ + + if (somev) { + *m = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (select[j]) { + ++(*m); + } +/* L10: */ + } + } else { + *m = *n; + } + + *info = 0; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else if (*mm < *m) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTREVC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Set the constants to control overflow. */ + + unfl = slamch_("Safe minimum"); + ovfl = 1.f / unfl; + slabad_(&unfl, &ovfl); + ulp = slamch_("Precision"); + smlnum = unfl * (*n / ulp); + +/* Store the diagonal elements of T in working array WORK. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + *n; + i__3 = i__ + i__ * t_dim1; + work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i; +/* L20: */ + } + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + rwork[1] = 0.f; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + rwork[j] = scasum_(&i__2, &t[j * t_dim1 + 1], &c__1); +/* L30: */ + } + + if (rightv) { + +/* Compute right eigenvectors. */ + + is = *m; + for (ki = *n; ki >= 1; --ki) { + + if (somev) { + if (! select[ki]) { + goto L80; + } + } +/* Computing MAX */ + i__1 = ki + ki * t_dim1; + r__3 = ulp * ((r__1 = t[i__1].r, abs(r__1)) + (r__2 = r_imag(&t[ + ki + ki * t_dim1]), abs(r__2))); + smin = f2cmax(r__3,smlnum); + + work[1].r = 1.f, work[1].i = 0.f; + +/* Form right-hand side. */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = k; + i__3 = k + ki * t_dim1; + q__1.r = -t[i__3].r, q__1.i = -t[i__3].i; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; +/* L40: */ + } + +/* Solve the triangular system: */ +/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = k + k * t_dim1; + i__3 = k + k * t_dim1; + i__4 = ki + ki * t_dim1; + q__1.r = t[i__3].r - t[i__4].r, q__1.i = t[i__3].i - t[i__4] + .i; + t[i__2].r = q__1.r, t[i__2].i = q__1.i; + i__2 = k + k * t_dim1; + if ((r__1 = t[i__2].r, abs(r__1)) + (r__2 = r_imag(&t[k + k * + t_dim1]), abs(r__2)) < smin) { + i__3 = k + k * t_dim1; + t[i__3].r = smin, t[i__3].i = 0.f; + } +/* L50: */ + } + + if (ki > 1) { + i__1 = ki - 1; + clatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[ + t_offset], ldt, &work[1], &scale, &rwork[1], info); + i__1 = ki; + work[i__1].r = scale, work[i__1].i = 0.f; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { + ccopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1); + + ii = icamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + i__1 = ii + is * vr_dim1; + remax = 1.f / ((r__1 = vr[i__1].r, abs(r__1)) + (r__2 = + r_imag(&vr[ii + is * vr_dim1]), abs(r__2))); + csscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + i__2 = k + is * vr_dim1; + vr[i__2].r = 0.f, vr[i__2].i = 0.f; +/* L60: */ + } + } else { + if (ki > 1) { + i__1 = ki - 1; + q__1.r = scale, q__1.i = 0.f; + cgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[ + 1], &c__1, &q__1, &vr[ki * vr_dim1 + 1], &c__1); + } + + ii = icamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + i__1 = ii + ki * vr_dim1; + remax = 1.f / ((r__1 = vr[i__1].r, abs(r__1)) + (r__2 = + r_imag(&vr[ii + ki * vr_dim1]), abs(r__2))); + csscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } + +/* Set back the original diagonal elements of T. */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = k + k * t_dim1; + i__3 = k + *n; + t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i; +/* L70: */ + } + + --is; +L80: + ; + } + } + + if (leftv) { + +/* Compute left eigenvectors. */ + + is = 1; + i__1 = *n; + for (ki = 1; ki <= i__1; ++ki) { + + if (somev) { + if (! select[ki]) { + goto L130; + } + } +/* Computing MAX */ + i__2 = ki + ki * t_dim1; + r__3 = ulp * ((r__1 = t[i__2].r, abs(r__1)) + (r__2 = r_imag(&t[ + ki + ki * t_dim1]), abs(r__2))); + smin = f2cmax(r__3,smlnum); + + i__2 = *n; + work[i__2].r = 1.f, work[i__2].i = 0.f; + +/* Form right-hand side. */ + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + i__3 = k; + r_cnjg(&q__2, &t[ki + k * t_dim1]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L90: */ + } + +/* Solve the triangular system: */ +/* (T(KI+1:N,KI+1:N) - T(KI,KI))**H*X = SCALE*WORK. */ + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + i__3 = k + k * t_dim1; + i__4 = k + k * t_dim1; + i__5 = ki + ki * t_dim1; + q__1.r = t[i__4].r - t[i__5].r, q__1.i = t[i__4].i - t[i__5] + .i; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + i__3 = k + k * t_dim1; + if ((r__1 = t[i__3].r, abs(r__1)) + (r__2 = r_imag(&t[k + k * + t_dim1]), abs(r__2)) < smin) { + i__4 = k + k * t_dim1; + t[i__4].r = smin, t[i__4].i = 0.f; + } +/* L100: */ + } + + if (ki < *n) { + i__2 = *n - ki; + clatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", & + i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki + + 1], &scale, &rwork[1], info); + i__2 = ki; + work[i__2].r = scale, work[i__2].i = 0.f; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { + i__2 = *n - ki + 1; + ccopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1) + ; + + i__2 = *n - ki + 1; + ii = icamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1; + i__2 = ii + is * vl_dim1; + remax = 1.f / ((r__1 = vl[i__2].r, abs(r__1)) + (r__2 = + r_imag(&vl[ii + is * vl_dim1]), abs(r__2))); + i__2 = *n - ki + 1; + csscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = k + is * vl_dim1; + vl[i__3].r = 0.f, vl[i__3].i = 0.f; +/* L110: */ + } + } else { + if (ki < *n) { + i__2 = *n - ki; + q__1.r = scale, q__1.i = 0.f; + cgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1], + ldvl, &work[ki + 1], &c__1, &q__1, &vl[ki * + vl_dim1 + 1], &c__1); + } + + ii = icamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + i__2 = ii + ki * vl_dim1; + remax = 1.f / ((r__1 = vl[i__2].r, abs(r__1)) + (r__2 = + r_imag(&vl[ii + ki * vl_dim1]), abs(r__2))); + csscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + } + +/* Set back the original diagonal elements of T. */ + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + i__3 = k + k * t_dim1; + i__4 = k + *n; + t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i; +/* L120: */ + } + + ++is; +L130: + ; + } + } + + return 0; + +/* End of CTREVC */ + +} /* ctrevc_ */ + diff --git a/lapack-netlib/SRC/ctrevc3.c b/lapack-netlib/SRC/ctrevc3.c new file mode 100644 index 000000000..e58b1fa14 --- /dev/null +++ b/lapack-netlib/SRC/ctrevc3.c @@ -0,0 +1,1164 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTREVC3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTREVC3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, */ +/* LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* REAL RWORK( * ) */ +/* COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTREVC3 computes some or all of the right and/or left eigenvectors of */ +/* > a complex upper triangular matrix T. */ +/* > Matrices of this type are produced by the Schur factorization of */ +/* > a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of T corresponding */ +/* > to an eigenvalue w are defined by: */ +/* > */ +/* > T*x = w*x, (y**H)*T = w*(y**H) */ +/* > */ +/* > where y**H denotes the conjugate transpose of the vector y. */ +/* > The eigenvalues are not input to this routine, but are read directly */ +/* > from the diagonal of T. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ +/* > input matrix. If Q is the unitary factor that reduces a matrix A to */ +/* > Schur form T, then Q*X and Q*Y are the matrices of right and left */ +/* > eigenvectors of A. */ +/* > */ +/* > This uses a Level 3 BLAS version of the back transformation. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed using the matrices supplied in */ +/* > VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > as indicated by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ +/* > computed. */ +/* > The eigenvector corresponding to the j-th eigenvalue is */ +/* > computed if SELECT(j) = .TRUE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > The upper triangular matrix T. T is modified, but restored */ +/* > on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the unitary matrix Q of */ +/* > Schur vectors returned by CHSEQR). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VL, in the same order as their */ +/* > eigenvalues. */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Q (usually the unitary matrix Q of */ +/* > Schur vectors returned by CHSEQR). */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*X; */ +/* > if HOWMNY = 'S', the right eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VR, in the same order as their */ +/* > eigenvalues. */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. */ +/* > If HOWMNY = 'A' or 'B', M is set to N. */ +/* > Each selected eigenvector occupies one column. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of array WORK. LWORK >= f2cmax(1,2*N). */ +/* > For optimum performance, LWORK >= N + 2*N*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (LRWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > The dimension of array RWORK. LRWORK >= f2cmax(1,N). */ +/* > */ +/* > If LRWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the RWORK array, returns */ +/* > this value as the first entry of the RWORK array, and no error */ +/* > message related to LRWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* @generated from ztrevc3.f, fortran z -> c, Tue Apr 19 01:47:44 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The algorithm used in this program is basically backward (forward) */ +/* > substitution, with scaling to make the the code robust against */ +/* > possible overflow. */ +/* > */ +/* > Each eigenvector is normalized so that the element of largest */ +/* > magnitude has magnitude 1; here the magnitude of a complex number */ +/* > (x,y) is taken to be |x| + |y|. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctrevc3_(char *side, char *howmny, logical *select, + integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, + complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, + integer *lwork, real *rwork, integer *lrwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2[2], i__3, i__4, i__5, i__6; + real r__1, r__2, r__3; + complex q__1, q__2; + char ch__1[2]; + + /* Local variables */ + logical allv; + real unfl, ovfl, smin; + logical over; + integer i__, j, k; + real scale; + extern /* Subroutine */ int 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 remax; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + logical leftv, bothv, somev; + integer nb, ii, ki; + extern /* Subroutine */ int slabad_(real *, real *); + integer is, iv; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), claset_(char *, integer *, integer *, complex *, complex *, + complex *, integer *), 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 /* Subroutine */ int clatrs_(char *, char *, char *, char *, + integer *, complex *, integer *, complex *, real *, real *, + integer *); + extern real scasum_(integer *, complex *, integer *); + logical rightv; + integer maxwrk; + real smlnum; + logical lquery; + real ulp; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --rwork; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors. */ + + if (somev) { + *m = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (select[j]) { + ++(*m); + } +/* L10: */ + } + } else { + *m = *n; + } + + *info = 0; +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = side; + i__2[1] = 1, a__1[1] = howmny; + s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "CTREVC", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)2); + maxwrk = *n + (*n << 1) * nb; + work[1].r = (real) maxwrk, work[1].i = 0.f; + rwork[1] = (real) (*n); + lquery = *lwork == -1 || *lrwork == -1; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else if (*mm < *m) { + *info = -11; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__3 = *n << 1; + if (*lwork < f2cmax(i__1,i__3) && ! lquery) { + *info = -14; + } else if (*lrwork < f2cmax(1,*n) && ! lquery) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTREVC3", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Use blocked version of back-transformation if sufficient workspace. */ +/* Zero-out the workspace to avoid potential NaN propagation. */ + + if (over && *lwork >= *n + (*n << 4)) { + nb = (*lwork - *n) / (*n << 1); + nb = f2cmin(nb,128); + i__1 = (nb << 1) + 1; + claset_("F", n, &i__1, &c_b1, &c_b1, &work[1], n); + } else { + nb = 1; + } + +/* Set the constants to control overflow. */ + + unfl = slamch_("Safe minimum"); + ovfl = 1.f / unfl; + slabad_(&unfl, &ovfl); + ulp = slamch_("Precision"); + smlnum = unfl * (*n / ulp); + +/* Store the diagonal elements of T in working array WORK. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__3 = i__; + i__4 = i__ + i__ * t_dim1; + work[i__3].r = t[i__4].r, work[i__3].i = t[i__4].i; +/* L20: */ + } + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + rwork[1] = 0.f; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__3 = j - 1; + rwork[j] = scasum_(&i__3, &t[j * t_dim1 + 1], &c__1); +/* L30: */ + } + + if (rightv) { + +/* ============================================================ */ +/* Compute right eigenvectors. */ + +/* IV is index of column in current block. */ +/* Non-blocked version always uses IV=NB=1; */ +/* blocked version starts with IV=NB, goes down to 1. */ +/* (Note the "0-th" column is used to store the original diagonal.) */ + iv = nb; + is = *m; + for (ki = *n; ki >= 1; --ki) { + if (somev) { + if (! select[ki]) { + goto L80; + } + } +/* Computing MAX */ + i__1 = ki + ki * t_dim1; + r__3 = ulp * ((r__1 = t[i__1].r, abs(r__1)) + (r__2 = r_imag(&t[ + ki + ki * t_dim1]), abs(r__2))); + smin = f2cmax(r__3,smlnum); + +/* -------------------------------------------------------- */ +/* Complex right eigenvector */ + + i__1 = ki + iv * *n; + work[i__1].r = 1.f, work[i__1].i = 0.f; + +/* Form right-hand side. */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + i__3 = k + iv * *n; + i__4 = k + ki * t_dim1; + q__1.r = -t[i__4].r, q__1.i = -t[i__4].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L40: */ + } + +/* Solve upper triangular system: */ +/* [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK. */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + i__3 = k + k * t_dim1; + i__4 = k + k * t_dim1; + i__5 = ki + ki * t_dim1; + q__1.r = t[i__4].r - t[i__5].r, q__1.i = t[i__4].i - t[i__5] + .i; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + i__3 = k + k * t_dim1; + if ((r__1 = t[i__3].r, abs(r__1)) + (r__2 = r_imag(&t[k + k * + t_dim1]), abs(r__2)) < smin) { + i__4 = k + k * t_dim1; + t[i__4].r = smin, t[i__4].i = 0.f; + } +/* L50: */ + } + + if (ki > 1) { + i__1 = ki - 1; + clatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[ + t_offset], ldt, &work[iv * *n + 1], &scale, &rwork[1], + info); + i__1 = ki + iv * *n; + work[i__1].r = scale, work[i__1].i = 0.f; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VR and normalize. */ + ccopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + 1], + &c__1); + + ii = icamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + i__1 = ii + is * vr_dim1; + remax = 1.f / ((r__1 = vr[i__1].r, abs(r__1)) + (r__2 = + r_imag(&vr[ii + is * vr_dim1]), abs(r__2))); + csscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + i__3 = k + is * vr_dim1; + vr[i__3].r = 0.f, vr[i__3].i = 0.f; +/* L60: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki > 1) { + i__1 = ki - 1; + q__1.r = scale, q__1.i = 0.f; + cgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[ + iv * *n + 1], &c__1, &q__1, &vr[ki * vr_dim1 + 1], + &c__1); + } + + ii = icamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + i__1 = ii + ki * vr_dim1; + remax = 1.f / ((r__1 = vr[i__1].r, abs(r__1)) + (r__2 = + r_imag(&vr[ii + ki * vr_dim1]), abs(r__2))); + csscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out below vector */ + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + i__3 = k + iv * *n; + work[i__3].r = 0.f, work[i__3].i = 0.f; + } + +/* Columns IV:NB of work are valid vectors. */ +/* When the number of vectors stored reaches NB, */ +/* or if this was last vector, do the GEMM */ + if (iv == 1 || ki == 1) { + i__1 = nb - iv + 1; + i__3 = ki + nb - iv; + cgemm_("N", "N", n, &i__1, &i__3, &c_b2, &vr[vr_offset], + ldvr, &work[iv * *n + 1], n, &c_b1, &work[(nb + + iv) * *n + 1], n); +/* normalize vectors */ + i__1 = nb; + for (k = iv; k <= i__1; ++k) { + ii = icamax_(n, &work[(nb + k) * *n + 1], &c__1); + i__3 = ii + (nb + k) * *n; + remax = 1.f / ((r__1 = work[i__3].r, abs(r__1)) + ( + r__2 = r_imag(&work[ii + (nb + k) * *n]), abs( + r__2))); + csscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + i__1 = nb - iv + 1; + clacpy_("F", n, &i__1, &work[(nb + iv) * *n + 1], n, &vr[ + ki * vr_dim1 + 1], ldvr); + iv = nb; + } else { + --iv; + } + } + +/* Restore the original diagonal elements of T. */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + i__3 = k + k * t_dim1; + i__4 = k; + t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i; +/* L70: */ + } + + --is; +L80: + ; + } + } + + if (leftv) { + +/* ============================================================ */ +/* Compute left eigenvectors. */ + +/* IV is index of column in current block. */ +/* Non-blocked version always uses IV=1; */ +/* blocked version starts with IV=1, goes up to NB. */ +/* (Note the "0-th" column is used to store the original diagonal.) */ + iv = 1; + is = 1; + i__1 = *n; + for (ki = 1; ki <= i__1; ++ki) { + + if (somev) { + if (! select[ki]) { + goto L130; + } + } +/* Computing MAX */ + i__3 = ki + ki * t_dim1; + r__3 = ulp * ((r__1 = t[i__3].r, abs(r__1)) + (r__2 = r_imag(&t[ + ki + ki * t_dim1]), abs(r__2))); + smin = f2cmax(r__3,smlnum); + +/* -------------------------------------------------------- */ +/* Complex left eigenvector */ + + i__3 = ki + iv * *n; + work[i__3].r = 1.f, work[i__3].i = 0.f; + +/* Form right-hand side. */ + + i__3 = *n; + for (k = ki + 1; k <= i__3; ++k) { + i__4 = k + iv * *n; + r_cnjg(&q__2, &t[ki + k * t_dim1]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + work[i__4].r = q__1.r, work[i__4].i = q__1.i; +/* L90: */ + } + +/* Solve conjugate-transposed triangular system: */ +/* [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK. */ + + i__3 = *n; + for (k = ki + 1; k <= i__3; ++k) { + i__4 = k + k * t_dim1; + i__5 = k + k * t_dim1; + i__6 = ki + ki * t_dim1; + q__1.r = t[i__5].r - t[i__6].r, q__1.i = t[i__5].i - t[i__6] + .i; + t[i__4].r = q__1.r, t[i__4].i = q__1.i; + i__4 = k + k * t_dim1; + if ((r__1 = t[i__4].r, abs(r__1)) + (r__2 = r_imag(&t[k + k * + t_dim1]), abs(r__2)) < smin) { + i__5 = k + k * t_dim1; + t[i__5].r = smin, t[i__5].i = 0.f; + } +/* L100: */ + } + + if (ki < *n) { + i__3 = *n - ki; + clatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", & + i__3, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki + + 1 + iv * *n], &scale, &rwork[1], info); + i__3 = ki + iv * *n; + work[i__3].r = scale, work[i__3].i = 0.f; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VL and normalize. */ + i__3 = *n - ki + 1; + ccopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + + i__3 = *n - ki + 1; + ii = icamax_(&i__3, &vl[ki + is * vl_dim1], &c__1) + ki - 1; + i__3 = ii + is * vl_dim1; + remax = 1.f / ((r__1 = vl[i__3].r, abs(r__1)) + (r__2 = + r_imag(&vl[ii + is * vl_dim1]), abs(r__2))); + i__3 = *n - ki + 1; + csscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1); + + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + is * vl_dim1; + vl[i__4].r = 0.f, vl[i__4].i = 0.f; +/* L110: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki < *n) { + i__3 = *n - ki; + q__1.r = scale, q__1.i = 0.f; + cgemv_("N", n, &i__3, &c_b2, &vl[(ki + 1) * vl_dim1 + 1], + ldvl, &work[ki + 1 + iv * *n], &c__1, &q__1, &vl[ + ki * vl_dim1 + 1], &c__1); + } + + ii = icamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + i__3 = ii + ki * vl_dim1; + remax = 1.f / ((r__1 = vl[i__3].r, abs(r__1)) + (r__2 = + r_imag(&vl[ii + ki * vl_dim1]), abs(r__2))); + csscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out above vector */ +/* could go from KI-NV+1 to KI-1 */ + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + iv * *n; + work[i__4].r = 0.f, work[i__4].i = 0.f; + } + +/* Columns 1:IV of work are valid vectors. */ +/* When the number of vectors stored reaches NB, */ +/* or if this was last vector, do the GEMM */ + if (iv == nb || ki == *n) { + i__3 = *n - ki + iv; + cgemm_("N", "N", n, &iv, &i__3, &c_b2, &vl[(ki - iv + 1) * + vl_dim1 + 1], ldvl, &work[ki - iv + 1 + *n], n, & + c_b1, &work[(nb + 1) * *n + 1], n); +/* normalize vectors */ + i__3 = iv; + for (k = 1; k <= i__3; ++k) { + ii = icamax_(n, &work[(nb + k) * *n + 1], &c__1); + i__4 = ii + (nb + k) * *n; + remax = 1.f / ((r__1 = work[i__4].r, abs(r__1)) + ( + r__2 = r_imag(&work[ii + (nb + k) * *n]), abs( + r__2))); + csscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + clacpy_("F", n, &iv, &work[(nb + 1) * *n + 1], n, &vl[(ki + - iv + 1) * vl_dim1 + 1], ldvl); + iv = 1; + } else { + ++iv; + } + } + +/* Restore the original diagonal elements of T. */ + + i__3 = *n; + for (k = ki + 1; k <= i__3; ++k) { + i__4 = k + k * t_dim1; + i__5 = k; + t[i__4].r = work[i__5].r, t[i__4].i = work[i__5].i; +/* L120: */ + } + + ++is; +L130: + ; + } + } + + return 0; + +/* End of CTREVC3 */ + +} /* ctrevc3_ */ + diff --git a/lapack-netlib/SRC/ctrexc.c b/lapack-netlib/SRC/ctrexc.c new file mode 100644 index 000000000..7893ef0a8 --- /dev/null +++ b/lapack-netlib/SRC/ctrexc.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 CTREXC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTREXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) */ + +/* CHARACTER COMPQ */ +/* INTEGER IFST, ILST, INFO, LDQ, LDT, N */ +/* COMPLEX Q( LDQ, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTREXC reorders the Schur factorization of a complex matrix */ +/* > A = Q*T*Q**H, so that the diagonal element of T with row index IFST */ +/* > is moved to row ILST. */ +/* > */ +/* > The Schur form T is reordered by a unitary similarity transformation */ +/* > Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by */ +/* > postmultplying it with Z. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'V': update the matrix Q of Schur vectors; */ +/* > = 'N': do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > If N == 0 arguments ILST and IFST may be any value. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > On entry, the upper triangular matrix T. */ +/* > On exit, the reordered upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* > On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* > unitary transformation matrix Z which reorders T. */ +/* > If COMPQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1, and if */ +/* > COMPQ = 'V', LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IFST */ +/* > \verbatim */ +/* > IFST is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILST */ +/* > \verbatim */ +/* > ILST is INTEGER */ +/* > */ +/* > Specify the reordering of the diagonal elements of T: */ +/* > The element with row index IFST is moved to row ILST by a */ +/* > sequence of transpositions between adjacent elements. */ +/* > 1 <= IFST <= N; 1 <= ILST <= 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 ctrexc_(char *compq, integer *n, complex *t, integer * + ldt, complex *q, integer *ldq, integer *ifst, integer *ilst, integer * + info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + complex temp; + extern /* Subroutine */ int crot_(integer *, complex *, integer *, + complex *, integer *, real *, complex *); + integer k; + extern logical lsame_(char *, char *); + logical wantq; + integer m1, m2, m3; + real cs; + complex t11, t22, sn; + extern /* Subroutine */ int clartg_(complex *, complex *, real *, complex + *, complex *), 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 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters. */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + + /* Function Body */ + *info = 0; + wantq = lsame_(compq, "V"); + if (! lsame_(compq, "N") && ! wantq) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldt < f2cmax(1,*n)) { + *info = -4; + } else if (*ldq < 1 || wantq && *ldq < f2cmax(1,*n)) { + *info = -6; + } else if ((*ifst < 1 || *ifst > *n) && *n > 0) { + *info = -7; + } else if ((*ilst < 1 || *ilst > *n) && *n > 0) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTREXC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1 || *ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + +/* Move the IFST-th diagonal element forward down the diagonal. */ + + m1 = 0; + m2 = -1; + m3 = 1; + } else { + +/* Move the IFST-th diagonal element backward up the diagonal. */ + + m1 = -1; + m2 = 0; + m3 = -1; + } + + i__1 = *ilst + m2; + i__2 = m3; + for (k = *ifst + m1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + +/* Interchange the k-th and (k+1)-th diagonal elements. */ + + i__3 = k + k * t_dim1; + t11.r = t[i__3].r, t11.i = t[i__3].i; + i__3 = k + 1 + (k + 1) * t_dim1; + t22.r = t[i__3].r, t22.i = t[i__3].i; + +/* Determine the transformation to perform the interchange. */ + + q__1.r = t22.r - t11.r, q__1.i = t22.i - t11.i; + clartg_(&t[k + (k + 1) * t_dim1], &q__1, &cs, &sn, &temp); + +/* Apply transformation to the matrix T. */ + + if (k + 2 <= *n) { + i__3 = *n - k - 1; + crot_(&i__3, &t[k + (k + 2) * t_dim1], ldt, &t[k + 1 + (k + 2) * + t_dim1], ldt, &cs, &sn); + } + i__3 = k - 1; + r_cnjg(&q__1, &sn); + crot_(&i__3, &t[k * t_dim1 + 1], &c__1, &t[(k + 1) * t_dim1 + 1], & + c__1, &cs, &q__1); + + i__3 = k + k * t_dim1; + t[i__3].r = t22.r, t[i__3].i = t22.i; + i__3 = k + 1 + (k + 1) * t_dim1; + t[i__3].r = t11.r, t[i__3].i = t11.i; + + if (wantq) { + +/* Accumulate transformation in the matrix Q. */ + + r_cnjg(&q__1, &sn); + crot_(n, &q[k * q_dim1 + 1], &c__1, &q[(k + 1) * q_dim1 + 1], & + c__1, &cs, &q__1); + } + +/* L10: */ + } + + return 0; + +/* End of CTREXC */ + +} /* ctrexc_ */ + diff --git a/lapack-netlib/SRC/ctrrfs.c b/lapack-netlib/SRC/ctrrfs.c new file mode 100644 index 000000000..cc14a0f10 --- /dev/null +++ b/lapack-netlib/SRC/ctrrfs.c @@ -0,0 +1,1008 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTRRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, */ +/* LDX, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDA, LDB, LDX, N, NRHS */ +/* REAL BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by CTRTRS or some other */ +/* > means before entering this routine. CTRRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \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 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] 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] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX,NRHS) */ +/* > The 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 */ + +/* 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 ctrrfs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, complex *a, integer *lda, 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, 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 *); + logical upper; + extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *, + complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *, + integer *, 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); + logical notran; + char transn[1], transt[1]; + logical nounit; + 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; + 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"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + 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 (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < 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_("CTRRFS", &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; + } + + if (notran) { + *(unsigned char *)transn = 'N'; + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transn = 'C'; + *(unsigned char *)transt = 'N'; + } + +/* 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) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); + ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1); + q__1.r = -1.f, q__1.i = 0.f; + caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + 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)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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; + 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; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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; +/* L50: */ + } + rwork[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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 = *n; + for (i__ = k; 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; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + 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 = *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; +/* L90: */ + } + rwork[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**H)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + 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))) + ; +/* L110: */ + } + rwork[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * x_dim1; + s = (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; + 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))) + ; +/* L130: */ + } + rwork[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + 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))) + ; +/* L150: */ + } + rwork[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * x_dim1; + s = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[ + k + j * x_dim1]), abs(r__2)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + 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))) + ; +/* L170: */ + } + rwork[k] += s; +/* L180: */ + } + } + } + } + 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); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use CLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (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; + } +/* L200: */ + } + + kase = 0; +L210: + clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**H). */ + + ctrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], & + c__1); + 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; +/* L220: */ + } + } else { + +/* Multiply by inv(op(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; +/* L230: */ + } + ctrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], & + c__1); + } + goto L210; + } + +/* 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); +/* L240: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of CTRRFS */ + +} /* ctrrfs_ */ + diff --git a/lapack-netlib/SRC/ctrsen.c b/lapack-netlib/SRC/ctrsen.c new file mode 100644 index 000000000..93a027f65 --- /dev/null +++ b/lapack-netlib/SRC/ctrsen.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 CTRSEN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRSEN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, */ +/* SEP, WORK, LWORK, INFO ) */ + +/* CHARACTER COMPQ, JOB */ +/* INTEGER INFO, LDQ, LDT, LWORK, M, N */ +/* REAL S, SEP */ +/* LOGICAL SELECT( * ) */ +/* COMPLEX Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRSEN reorders the Schur factorization of a complex matrix */ +/* > A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in */ +/* > the leading positions on the diagonal of the upper triangular matrix */ +/* > T, and the leading columns of Q form an orthonormal basis of the */ +/* > corresponding right invariant subspace. */ +/* > */ +/* > Optionally the routine computes the reciprocal condition numbers of */ +/* > the cluster of eigenvalues and/or the invariant subspace. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for the */ +/* > cluster of eigenvalues (S) or the invariant subspace (SEP): */ +/* > = 'N': none; */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for invariant subspace only (SEP); */ +/* > = 'B': for both eigenvalues and invariant subspace (S and */ +/* > SEP). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'V': update the matrix Q of Schur vectors; */ +/* > = 'N': do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > SELECT specifies the eigenvalues in the selected cluster. To */ +/* > select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > On entry, the upper triangular matrix T. */ +/* > On exit, T is overwritten by the reordered matrix T, with the */ +/* > selected eigenvalues as the leading diagonal elements. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* > On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* > unitary transformation matrix which reorders T; the leading M */ +/* > columns of Q form an orthonormal basis for the specified */ +/* > invariant subspace. */ +/* > If COMPQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX array, dimension (N) */ +/* > The reordered eigenvalues of T, in the same order as they */ +/* > appear on the diagonal of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the specified invariant subspace. */ +/* > 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL */ +/* > If JOB = 'E' or 'B', S is a lower bound on the reciprocal */ +/* > condition number for the selected cluster of eigenvalues. */ +/* > S cannot underestimate the true reciprocal condition number */ +/* > by more than a factor of sqrt(N). If M = 0 or N, S = 1. */ +/* > If JOB = 'N' or 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SEP */ +/* > \verbatim */ +/* > SEP is REAL */ +/* > If JOB = 'V' or 'B', SEP is the estimated reciprocal */ +/* > condition number of the specified invariant subspace. If */ +/* > M = 0 or N, SEP = norm(T). */ +/* > If JOB = 'N' or 'E', SEP is not referenced. */ +/* > \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 JOB = 'N', LWORK >= 1; */ +/* > if JOB = 'E', LWORK = f2cmax(1,M*(N-M)); */ +/* > if JOB = 'V' or 'B', LWORK >= f2cmax(1,2*M*(N-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. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRSEN first collects the selected eigenvalues by computing a unitary */ +/* > transformation Z to move them to the top left corner of T. In other */ +/* > words, the selected eigenvalues are the eigenvalues of T11 in: */ +/* > */ +/* > Z**H * T * Z = ( T11 T12 ) n1 */ +/* > ( 0 T22 ) n2 */ +/* > n1 n2 */ +/* > */ +/* > where N = n1+n2. The first */ +/* > n1 columns of Z span the specified invariant subspace of T. */ +/* > */ +/* > If T has been obtained from the Schur factorization of a matrix */ +/* > A = Q*T*Q**H, then the reordered Schur factorization of A is given by */ +/* > A = (Q*Z)*(Z**H*T*Z)*(Q*Z)**H, and the first n1 columns of Q*Z span the */ +/* > corresponding invariant subspace of A. */ +/* > */ +/* > The reciprocal condition number of the average of the eigenvalues of */ +/* > T11 may be returned in S. S lies between 0 (very badly conditioned) */ +/* > and 1 (very well conditioned). It is computed as follows. First we */ +/* > compute R so that */ +/* > */ +/* > P = ( I R ) n1 */ +/* > ( 0 0 ) n2 */ +/* > n1 n2 */ +/* > */ +/* > is the projector on the invariant subspace associated with T11. */ +/* > R is the solution of the Sylvester equation: */ +/* > */ +/* > T11*R - R*T22 = T12. */ +/* > */ +/* > Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */ +/* > the two-norm of M. Then S is computed as the lower bound */ +/* > */ +/* > (1 + F-norm(R)**2)**(-1/2) */ +/* > */ +/* > on the reciprocal of 2-norm(P), the true reciprocal condition number. */ +/* > S cannot underestimate 1 / 2-norm(P) by more than a factor of */ +/* > sqrt(N). */ +/* > */ +/* > An approximate error bound for the computed average of the */ +/* > eigenvalues of T11 is */ +/* > */ +/* > EPS * norm(T) / S */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal condition number of the right invariant subspace */ +/* > spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */ +/* > SEP is defined as the separation of T11 and T22: */ +/* > */ +/* > sep( T11, T22 ) = sigma-f2cmin( C ) */ +/* > */ +/* > where sigma-f2cmin(C) is the smallest singular value of the */ +/* > n1*n2-by-n1*n2 matrix */ +/* > */ +/* > C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */ +/* > */ +/* > I(m) is an m by m identity matrix, and kprod denotes the Kronecker */ +/* > product. We estimate sigma-f2cmin(C) by the reciprocal of an estimate of */ +/* > the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */ +/* > cannot differ from sigma-f2cmin(C) by more than a factor of sqrt(n1*n2). */ +/* > */ +/* > When SEP is small, small changes in T can cause large changes in */ +/* > the invariant subspace. An approximate bound on the maximum angular */ +/* > error in the computed right invariant subspace is */ +/* > */ +/* > EPS * norm(T) / SEP */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctrsen_(char *job, char *compq, logical *select, integer + *n, complex *t, integer *ldt, complex *q, integer *ldq, complex *w, + integer *m, real *s, real *sep, complex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3; + + /* Local variables */ + integer kase, ierr, k; + real scale; + extern logical lsame_(char *, char *); + integer isave[3], lwmin; + logical wantq, wants; + real rnorm; + integer n1, n2; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + real rwork[1]; + extern real clange_(char *, integer *, integer *, complex *, integer *, + real *); + integer nn, ks; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + logical wantbh; + extern /* Subroutine */ int ctrexc_(char *, integer *, complex *, integer + *, complex *, integer *, integer *, integer *, integer *); + logical wantsp; + extern /* Subroutine */ int ctrsyl_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, real *, integer *); + logical lquery; + real est; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters. */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --w; + --work; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + wantq = lsame_(compq, "V"); + +/* Set M to the number of selected eigenvalues. */ + + *m = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (select[k]) { + ++(*m); + } +/* L10: */ + } + + n1 = *m; + n2 = *n - *m; + nn = n1 * n2; + + *info = 0; + lquery = *lwork == -1; + + if (wantsp) { +/* Computing MAX */ + i__1 = 1, i__2 = nn << 1; + lwmin = f2cmax(i__1,i__2); + } else if (lsame_(job, "N")) { + lwmin = 1; + } else if (lsame_(job, "E")) { + lwmin = f2cmax(1,nn); + } + + if (! lsame_(job, "N") && ! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(compq, "N") && ! wantq) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -8; + } else if (*lwork < lwmin && ! lquery) { + *info = -14; + } + + if (*info == 0) { + work[1].r = (real) lwmin, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRSEN", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == *n || *m == 0) { + if (wants) { + *s = 1.f; + } + if (wantsp) { + *sep = clange_("1", n, n, &t[t_offset], ldt, rwork); + } + goto L40; + } + +/* Collect the selected eigenvalues at the top left corner of T. */ + + ks = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (select[k]) { + ++ks; + +/* Swap the K-th eigenvalue to position KS. */ + + if (k != ks) { + ctrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &k, & + ks, &ierr); + } + } +/* L20: */ + } + + if (wants) { + +/* Solve the Sylvester equation for R: */ + +/* T11*R - R*T22 = scale*T12 */ + + clacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1); + ctrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr); + +/* Estimate the reciprocal of the condition number of the cluster */ +/* of eigenvalues. */ + + rnorm = clange_("F", &n1, &n2, &work[1], &n1, rwork); + if (rnorm == 0.f) { + *s = 1.f; + } else { + *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm)); + } + } + + if (wantsp) { + +/* Estimate sep(T11,T22). */ + + est = 0.f; + kase = 0; +L30: + clacn2_(&nn, &work[nn + 1], &work[1], &est, &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve T11*R - R*T22 = scale*X. */ + + ctrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } else { + +/* Solve T11**H*R - R*T22**H = scale*X. */ + + ctrsyl_("C", "C", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } + goto L30; + } + + *sep = scale / est; + } + +L40: + +/* Copy reordered eigenvalues to W. */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k; + i__3 = k + k * t_dim1; + w[i__2].r = t[i__3].r, w[i__2].i = t[i__3].i; +/* L50: */ + } + + work[1].r = (real) lwmin, work[1].i = 0.f; + + return 0; + +/* End of CTRSEN */ + +} /* ctrsen_ */ + diff --git a/lapack-netlib/SRC/ctrsna.c b/lapack-netlib/SRC/ctrsna.c new file mode 100644 index 000000000..4d81b2a89 --- /dev/null +++ b/lapack-netlib/SRC/ctrsna.c @@ -0,0 +1,904 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTRSNA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRSNA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, */ +/* LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER HOWMNY, JOB */ +/* INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* REAL RWORK( * ), S( * ), SEP( * ) */ +/* COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRSNA estimates reciprocal condition numbers for specified */ +/* > eigenvalues and/or right eigenvectors of a complex upper triangular */ +/* > matrix T (or of any matrix Q*T*Q**H with Q unitary). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for */ +/* > eigenvalues (S) or eigenvectors (SEP): */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for eigenvectors only (SEP); */ +/* > = 'B': for both eigenvalues and eigenvectors (S and SEP). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute condition numbers for all eigenpairs; */ +/* > = 'S': compute condition numbers for selected eigenpairs */ +/* > specified by the array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* > condition numbers are required. To select condition numbers */ +/* > for the j-th eigenpair, SELECT(j) must be set to .TRUE.. */ +/* > If HOWMNY = 'A', SELECT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX array, dimension (LDT,N) */ +/* > The upper triangular matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is COMPLEX array, dimension (LDVL,M) */ +/* > If JOB = 'E' or 'B', VL must contain left eigenvectors of T */ +/* > (or of any Q*T*Q**H with Q unitary), corresponding to the */ +/* > eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* > must be stored in consecutive columns of VL, as returned by */ +/* > CHSEIN or CTREVC. */ +/* > If JOB = 'V', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VR */ +/* > \verbatim */ +/* > VR is COMPLEX array, dimension (LDVR,M) */ +/* > If JOB = 'E' or 'B', VR must contain right eigenvectors of T */ +/* > (or of any Q*T*Q**H with Q unitary), corresponding to the */ +/* > eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* > must be stored in consecutive columns of VR, as returned by */ +/* > CHSEIN or CTREVC. */ +/* > If JOB = 'V', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (MM) */ +/* > If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* > selected eigenvalues, stored in consecutive elements of the */ +/* > array. Thus S(j), SEP(j), and the j-th columns of VL and VR */ +/* > all correspond to the same eigenpair (but not in general the */ +/* > j-th eigenpair, unless all eigenpairs are selected). */ +/* > If JOB = 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SEP */ +/* > \verbatim */ +/* > SEP is REAL array, dimension (MM) */ +/* > If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* > numbers of the selected eigenvectors, stored in consecutive */ +/* > elements of the array. */ +/* > If JOB = 'E', SEP is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of elements in the arrays S (if JOB = 'E' or 'B') */ +/* > and/or SEP (if JOB = 'V' or 'B'). MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of elements of the arrays S and/or SEP actually */ +/* > used to store the estimated condition numbers. */ +/* > If HOWMNY = 'A', M is set to N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LDWORK,N+6) */ +/* > If JOB = 'E', WORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (N) */ +/* > If JOB = 'E', RWORK 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 */ +/* > \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 reciprocal of the condition number of an eigenvalue lambda is */ +/* > defined as */ +/* > */ +/* > S(lambda) = |v**H*u| / (norm(u)*norm(v)) */ +/* > */ +/* > where u and v are the right and left eigenvectors of T corresponding */ +/* > to lambda; v**H denotes the conjugate transpose of v, and norm(u) */ +/* > denotes the Euclidean norm. These reciprocal condition numbers always */ +/* > lie between zero (very badly conditioned) and one (very well */ +/* > conditioned). If n = 1, S(lambda) is defined to be 1. */ +/* > */ +/* > An approximate error bound for a computed eigenvalue W(i) is given by */ +/* > */ +/* > EPS * norm(T) / S(i) */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal of the condition number of the right eigenvector u */ +/* > corresponding to lambda is defined as follows. Suppose */ +/* > */ +/* > T = ( lambda c ) */ +/* > ( 0 T22 ) */ +/* > */ +/* > Then the reciprocal condition number is */ +/* > */ +/* > SEP( lambda, T22 ) = sigma-f2cmin( T22 - lambda*I ) */ +/* > */ +/* > where sigma-f2cmin denotes the smallest singular value. We approximate */ +/* > the smallest singular value by the reciprocal of an estimate of the */ +/* > one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */ +/* > defined to be abs(T(1,1)). */ +/* > */ +/* > An approximate error bound for a computed right eigenvector VR(i) */ +/* > is given by */ +/* > */ +/* > EPS * norm(T) / SEP(i) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctrsna_(char *job, char *howmny, logical *select, + integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, + complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer * + m, complex *work, integer *ldwork, real *rwork, integer *info) +{ + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, + work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2; + complex q__1; + + /* Local variables */ + integer kase, ierr; + complex prod; + real lnrm, rnrm; + integer i__, j, k; + real scale; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + integer isave[3]; + complex dummy[1]; + logical wants; + extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real + *, integer *, integer *); + real xnorm; + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int slabad_(real *, real *); + integer ks, ix; + extern integer icamax_(integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + real bignum; + logical wantbh; + extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, + integer *, complex *, integer *, complex *, real *, real *, + integer *), csrscl_(integer *, + real *, complex *, integer *), ctrexc_(char *, integer *, complex + *, integer *, complex *, integer *, integer *, integer *, integer + *); + logical somcon; + char normin[1]; + real smlnum; + logical wantsp; + real eps, est; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --s; + --sep; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + --rwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + +/* Set M to the number of eigenpairs for which condition numbers are */ +/* to be computed. */ + + if (somcon) { + *m = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (select[j]) { + ++(*m); + } +/* L10: */ + } + } else { + *m = *n; + } + + *info = 0; + if (! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || wants && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || wants && *ldvr < *n) { + *info = -10; + } else if (*mm < *m) { + *info = -13; + } else if (*ldwork < 1 || wantsp && *ldwork < *n) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRSNA", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (somcon) { + if (! select[1]) { + return 0; + } + } + if (wants) { + s[1] = 1.f; + } + if (wantsp) { + sep[1] = c_abs(&t[t_dim1 + 1]); + } + return 0; + } + +/* Get machine constants */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + + ks = 1; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + + if (somcon) { + if (! select[k]) { + goto L50; + } + } + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + cdotc_(&q__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 + + 1], &c__1); + prod.r = q__1.r, prod.i = q__1.i; + rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + s[ks] = c_abs(&prod) / (rnrm * lnrm); + + } + + if (wantsp) { + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvector. */ + +/* Copy the matrix T to the array WORK and swap the k-th */ +/* diagonal element to the (1,1) position. */ + + clacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], + ldwork); + ctrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, & + c__1, &ierr); + +/* Form C = T22 - lambda*I in WORK(2:N,2:N). */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + i__ * work_dim1; + i__4 = i__ + i__ * work_dim1; + i__5 = work_dim1 + 1; + q__1.r = work[i__4].r - work[i__5].r, q__1.i = work[i__4].i - + work[i__5].i; + work[i__3].r = q__1.r, work[i__3].i = q__1.i; +/* L20: */ + } + +/* Estimate a lower bound for the 1-norm of inv(C**H). The 1st */ +/* and (N+1)th columns of WORK are used to store work vectors. */ + + sep[ks] = 0.f; + est = 0.f; + kase = 0; + *(unsigned char *)normin = 'N'; +L30: + i__2 = *n - 1; + clacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset] + , &est, &kase, isave); + + if (kase != 0) { + if (kase == 1) { + +/* Solve C**H*x = scale*b */ + + i__2 = *n - 1; + clatrs_("Upper", "Conjugate transpose", "Nonunit", normin, + &i__2, &work[(work_dim1 << 1) + 2], ldwork, & + work[work_offset], &scale, &rwork[1], &ierr); + } else { + +/* Solve C*x = scale*b */ + + i__2 = *n - 1; + clatrs_("Upper", "No transpose", "Nonunit", normin, &i__2, + &work[(work_dim1 << 1) + 2], ldwork, &work[ + work_offset], &scale, &rwork[1], &ierr); + } + *(unsigned char *)normin = 'Y'; + if (scale != 1.f) { + +/* Multiply by 1/SCALE if doing so will not cause */ +/* overflow. */ + + i__2 = *n - 1; + ix = icamax_(&i__2, &work[work_offset], &c__1); + i__2 = ix + work_dim1; + xnorm = (r__1 = work[i__2].r, abs(r__1)) + (r__2 = r_imag( + &work[ix + work_dim1]), abs(r__2)); + if (scale < xnorm * smlnum || scale == 0.f) { + goto L40; + } + csrscl_(n, &scale, &work[work_offset], &c__1); + } + goto L30; + } + + sep[ks] = 1.f / f2cmax(est,smlnum); + } + +L40: + ++ks; +L50: + ; + } + return 0; + +/* End of CTRSNA */ + +} /* ctrsna_ */ + diff --git a/lapack-netlib/SRC/ctrsyl.c b/lapack-netlib/SRC/ctrsyl.c new file mode 100644 index 000000000..336064771 --- /dev/null +++ b/lapack-netlib/SRC/ctrsyl.c @@ -0,0 +1,984 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTRSYL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRSYL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, */ +/* LDC, SCALE, INFO ) */ + +/* CHARACTER TRANA, TRANB */ +/* INTEGER INFO, ISGN, LDA, LDB, LDC, M, N */ +/* REAL SCALE */ +/* COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRSYL solves the complex Sylvester matrix equation: */ +/* > */ +/* > op(A)*X + X*op(B) = scale*C or */ +/* > op(A)*X - X*op(B) = scale*C, */ +/* > */ +/* > where op(A) = A or A**H, and A and B are both upper triangular. A is */ +/* > M-by-M and B is N-by-N; the right hand side C and the solution X are */ +/* > M-by-N; and scale is an output scale factor, set <= 1 to avoid */ +/* > overflow in X. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANA */ +/* > \verbatim */ +/* > TRANA is CHARACTER*1 */ +/* > Specifies the option op(A): */ +/* > = 'N': op(A) = A (No transpose) */ +/* > = 'C': op(A) = A**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANB */ +/* > \verbatim */ +/* > TRANB is CHARACTER*1 */ +/* > Specifies the option op(B): */ +/* > = 'N': op(B) = B (No transpose) */ +/* > = 'C': op(B) = B**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISGN */ +/* > \verbatim */ +/* > ISGN is INTEGER */ +/* > Specifies the sign in the equation: */ +/* > = +1: solve op(A)*X + X*op(B) = scale*C */ +/* > = -1: solve op(A)*X - X*op(B) = scale*C */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The order of the matrix A, and the number of rows in the */ +/* > matrices X and C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix B, and the number of columns in the */ +/* > matrices X and C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,M) */ +/* > The upper triangular matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > The upper triangular 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] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N right hand side matrix C. */ +/* > On exit, C is overwritten by the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scale factor, scale, set <= 1 to avoid overflow in X. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1: A and B have common or very close eigenvalues; perturbed */ +/* > values were used to solve the equation (but the matrices */ +/* > A and B are unchanged). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer + *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, + complex *c__, integer *ldc, real *scale, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + real r__1, r__2; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + real smin; + complex suml, sumr; + integer j, k, l; + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer + *, complex *, integer *); + complex a11; + real db; + extern /* Subroutine */ int slabad_(real *, real *); + extern real clange_(char *, integer *, integer *, complex *, integer *, + real *); + complex x11; + extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); + real scaloc; + extern real slamch_(char *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + real bignum; + logical notrna, notrnb; + real smlnum, da11; + complex vec; + real dum[1], eps, sgn; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N"); + notrnb = lsame_(tranb, "N"); + + *info = 0; + if (! notrna && ! lsame_(trana, "C")) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "C")) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRSYL", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *scale = 1.f; + if (*m == 0 || *n == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = slamch_("P"); + smlnum = slamch_("S"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + smlnum = smlnum * (real) (*m * *n) / eps; + bignum = 1.f / smlnum; +/* Computing MAX */ + r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = f2cmax(r__1,r__2), r__2 = eps * clange_("M", n, n, + &b[b_offset], ldb, dum); + smin = f2cmax(r__1,r__2); + sgn = (real) (*isgn); + + if (notrna && notrnb) { + +/* Solve A*X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-left corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* M L-1 */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. */ +/* I=K+1 J=1 */ + + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + for (k = *m; k >= 1; --k) { + + i__2 = *m - k; +/* Computing MIN */ + i__3 = k + 1; +/* Computing MIN */ + i__4 = k + 1; + cdotu_(&q__1, &i__2, &a[k + f2cmin(i__3,*m) * a_dim1], lda, &c__[ + f2cmin(i__4,*m) + l * c_dim1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__2 = l - 1; + cdotu_(&q__1, &i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] + , &c__1); + sumr.r = q__1.r, sumr.i = q__1.i; + i__2 = k + l * c_dim1; + q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + + scaloc = 1.f; + i__2 = k + k * a_dim1; + i__3 = l + l * b_dim1; + q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i; + q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, abs(r__1)) + (r__2 = r_imag(&a11), abs( + r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, abs(r__1)) + (r__2 = r_imag(&vec), abs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + cladiv_(&q__1, &q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + i__2 = k + l * c_dim1; + c__[i__2].r = x11.r, c__[i__2].i = x11.i; + +/* L20: */ + } +/* L30: */ + } + + } else if (! notrna && notrnb) { + +/* Solve A**H *X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* upper-left corner column by column by */ + +/* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 L-1 */ +/* R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] */ +/* I=1 J=1 */ + + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + + i__3 = k - 1; + cdotc_(&q__1, &i__3, &a[k * a_dim1 + 1], &c__1, &c__[l * + c_dim1 + 1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__3 = l - 1; + cdotu_(&q__1, &i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] + , &c__1); + sumr.r = q__1.r, sumr.i = q__1.i; + i__3 = k + l * c_dim1; + q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + + scaloc = 1.f; + r_cnjg(&q__2, &a[k + k * a_dim1]); + i__3 = l + l * b_dim1; + q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, abs(r__1)) + (r__2 = r_imag(&a11), abs( + r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, abs(r__1)) + (r__2 = r_imag(&vec), abs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + cladiv_(&q__1, &q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + i__3 = k + l * c_dim1; + c__[i__3].r = x11.r, c__[i__3].i = x11.i; + +/* L50: */ + } +/* L60: */ + } + + } else if (! notrna && ! notrnb) { + +/* Solve A**H*X + ISGN*X*B**H = C. */ + +/* The (K,L)th block of X is determined starting from */ +/* upper-right corner column by column by */ + +/* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 */ +/* R(K,L) = SUM [A**H(I,K)*X(I,L)] + */ +/* I=1 */ +/* N */ +/* ISGN*SUM [X(K,J)*B**H(L,J)]. */ +/* J=L+1 */ + + for (l = *n; l >= 1; --l) { + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + + i__2 = k - 1; + cdotc_(&q__1, &i__2, &a[k * a_dim1 + 1], &c__1, &c__[l * + c_dim1 + 1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__2 = *n - l; +/* Computing MIN */ + i__3 = l + 1; +/* Computing MIN */ + i__4 = l + 1; + cdotc_(&q__1, &i__2, &c__[k + f2cmin(i__3,*n) * c_dim1], ldc, &b[ + l + f2cmin(i__4,*n) * b_dim1], ldb); + sumr.r = q__1.r, sumr.i = q__1.i; + i__2 = k + l * c_dim1; + r_cnjg(&q__4, &sumr); + q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + + scaloc = 1.f; + i__2 = k + k * a_dim1; + i__3 = l + l * b_dim1; + q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; + q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i; + r_cnjg(&q__1, &q__2); + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, abs(r__1)) + (r__2 = r_imag(&a11), abs( + r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, abs(r__1)) + (r__2 = r_imag(&vec), abs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + cladiv_(&q__1, &q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + i__2 = k + l * c_dim1; + c__[i__2].r = x11.r, c__[i__2].i = x11.i; + +/* L80: */ + } +/* L90: */ + } + + } else if (notrna && ! notrnb) { + +/* Solve A*X + ISGN*X*B**H = C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-left corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* M N */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)] */ +/* I=K+1 J=L+1 */ + + for (l = *n; l >= 1; --l) { + for (k = *m; k >= 1; --k) { + + i__1 = *m - k; +/* Computing MIN */ + i__2 = k + 1; +/* Computing MIN */ + i__3 = k + 1; + cdotu_(&q__1, &i__1, &a[k + f2cmin(i__2,*m) * a_dim1], lda, &c__[ + f2cmin(i__3,*m) + l * c_dim1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__1 = *n - l; +/* Computing MIN */ + i__2 = l + 1; +/* Computing MIN */ + i__3 = l + 1; + cdotc_(&q__1, &i__1, &c__[k + f2cmin(i__2,*n) * c_dim1], ldc, &b[ + l + f2cmin(i__3,*n) * b_dim1], ldb); + sumr.r = q__1.r, sumr.i = q__1.i; + i__1 = k + l * c_dim1; + r_cnjg(&q__4, &sumr); + q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + + scaloc = 1.f; + i__1 = k + k * a_dim1; + r_cnjg(&q__3, &b[l + l * b_dim1]); + q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i; + q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i; + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, abs(r__1)) + (r__2 = r_imag(&a11), abs( + r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, abs(r__1)) + (r__2 = r_imag(&vec), abs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + cladiv_(&q__1, &q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + i__1 = k + l * c_dim1; + c__[i__1].r = x11.r, c__[i__1].i = x11.i; + +/* L110: */ + } +/* L120: */ + } + + } + + return 0; + +/* End of CTRSYL */ + +} /* ctrsyl_ */ + diff --git a/lapack-netlib/SRC/ctrti2.c b/lapack-netlib/SRC/ctrti2.c new file mode 100644 index 000000000..9c5ffdfe6 --- /dev/null +++ b/lapack-netlib/SRC/ctrti2.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 CTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRTI2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRTI2 computes the inverse of a complex upper or lower triangular */ +/* > matrix. */ +/* > */ +/* > This is the Level 2 BLAS version of the algorithm. */ +/* > \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] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, 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. */ +/* > */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + complex q__1; + + /* Local variables */ + integer j; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *, + complex *, integer *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + logical nounit; + complex 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"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRTI2", &i__1, (ftnlen)6); + return 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + i__2 = j + j * a_dim1; + c_div(&q__1, &c_b1, &a[j + j * a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + j * a_dim1; + q__1.r = -a[i__2].r, q__1.i = -a[i__2].i; + ajj.r = q__1.r, ajj.i = q__1.i; + } else { + q__1.r = -1.f, q__1.i = 0.f; + ajj.r = q__1.r, ajj.i = q__1.i; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + ctrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & + a[j * a_dim1 + 1], &c__1); + i__2 = j - 1; + cscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Compute inverse of lower triangular matrix. */ + + for (j = *n; j >= 1; --j) { + if (nounit) { + i__1 = j + j * a_dim1; + c_div(&q__1, &c_b1, &a[j + j * a_dim1]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = j + j * a_dim1; + q__1.r = -a[i__1].r, q__1.i = -a[i__1].i; + ajj.r = q__1.r, ajj.i = q__1.i; + } else { + q__1.r = -1.f, q__1.i = 0.f; + ajj.r = q__1.r, ajj.i = q__1.i; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + ctrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j + + 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1); + i__1 = *n - j; + cscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); + } +/* L20: */ + } + } + + return 0; + +/* End of CTRTI2 */ + +} /* ctrti2_ */ + diff --git a/lapack-netlib/SRC/ctrtri.c b/lapack-netlib/SRC/ctrtri.c new file mode 100644 index 000000000..76ed64b24 --- /dev/null +++ b/lapack-netlib/SRC/ctrtri.c @@ -0,0 +1,668 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTRTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRTRI computes the inverse of a complex upper or lower triangular */ +/* > matrix A. */ +/* > */ +/* > This is the Level 3 BLAS version of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit 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 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. */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \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, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can 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 ctrtri_(char *uplo, char *diag, integer *n, complex *a, + integer *lda, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, i__1, i__2, i__3[2], i__4, i__5; + complex q__1; + char ch__1[2]; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *), ctrsm_(char *, char *, + char *, char *, integer *, integer *, complex *, complex *, + integer *, complex *, integer *); + logical upper; + extern /* Subroutine */ int ctrti2_(char *, char *, integer *, complex *, + integer *, integer *); + integer jb, nb, nn; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical nounit; + + +/* -- 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"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (a[i__2].r == 0.f && a[i__2].i == 0.f) { + return 0; + } +/* L10: */ + } + *info = 0; + } + +/* Determine the block size for this environment. */ + +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = uplo; + i__3[1] = 1, a__1[1] = diag; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "CTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)2); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + ctrti2_(uplo, diag, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute inverse of upper triangular matrix */ + + i__1 = *n; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *n - j + 1; + jb = f2cmin(i__4,i__5); + +/* Compute rows 1:j-1 of current block column */ + + i__4 = j - 1; + ctrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & + c_b1, &a[a_offset], lda, &a[j * a_dim1 + 1], lda); + i__4 = j - 1; + q__1.r = -1.f, q__1.i = 0.f; + ctrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & + q__1, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], + lda); + +/* Compute inverse of current diagonal block */ + + ctrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L20: */ + } + } else { + +/* Compute inverse of lower triangular matrix */ + + nn = (*n - 1) / nb * nb + 1; + i__2 = -nb; + for (j = nn; i__2 < 0 ? j >= 1 : j <= 1; j += i__2) { +/* Computing MIN */ + i__1 = nb, i__4 = *n - j + 1; + jb = f2cmin(i__1,i__4); + if (j + jb <= *n) { + +/* Compute rows j+jb:n of current block column */ + + i__1 = *n - j - jb + 1; + ctrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, + &c_b1, &a[j + jb + (j + jb) * a_dim1], lda, &a[j + + jb + j * a_dim1], lda); + i__1 = *n - j - jb + 1; + q__1.r = -1.f, q__1.i = 0.f; + ctrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, + &q__1, &a[j + j * a_dim1], lda, &a[j + jb + j * + a_dim1], lda); + } + +/* Compute inverse of current diagonal block */ + + ctrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L30: */ + } + } + } + + return 0; + +/* End of CTRTRI */ + +} /* ctrtri_ */ + diff --git a/lapack-netlib/SRC/ctrtrs.c b/lapack-netlib/SRC/ctrtrs.c new file mode 100644 index 000000000..08ed9b73c --- /dev/null +++ b/lapack-netlib/SRC/ctrtrs.c @@ -0,0 +1,621 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTRTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, */ +/* INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* COMPLEX A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B, A**T * X = B, or A**H * X = B, */ +/* > */ +/* > where A is a triangular matrix of order N, and B is an N-by-NRHS */ +/* > matrix. A check is made to verify that A is nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \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 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] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, if INFO = 0, 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 */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the solutions */ +/* > X have 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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int ctrtrs_(char *uplo, char *trans, char *diag, 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, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *), xerbla_(char *, + integer *, ftnlen); + logical nounit; + + +/* -- 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; + nounit = lsame_(diag, "N"); + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (a[i__2].r == 0.f && a[i__2].i == 0.f) { + return 0; + } +/* L10: */ + } + } + *info = 0; + +/* Solve A * x = b, A**T * x = b, or A**H * x = b. */ + + ctrsm_("Left", uplo, trans, diag, n, nrhs, &c_b2, &a[a_offset], lda, &b[ + b_offset], ldb); + + return 0; + +/* End of CTRTRS */ + +} /* ctrtrs_ */ + diff --git a/lapack-netlib/SRC/ctrttf.c b/lapack-netlib/SRC/ctrttf.c new file mode 100644 index 000000000..574a3d253 --- /dev/null +++ b/lapack-netlib/SRC/ctrttf.c @@ -0,0 +1,1006 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full pa +cked format (TF). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRTTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N, LDA */ +/* COMPLEX A( 0: LDA-1, 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRTTF copies a triangular matrix A from standard full format (TR) */ +/* > to rectangular full packed format (TF) . */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF in Normal mode is wanted; */ +/* > = 'C': ARF in Conjugate Transpose mode is wanted; */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \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 ) */ +/* > On entry, 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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the matrix A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ARF */ +/* > \verbatim */ +/* > ARF is COMPLEX array, dimension ( N*(N+1)/2 ), */ +/* > On exit, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup 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 ctrttf_(char *transr, char *uplo, integer *n, complex *a, + integer *lda, complex *arf, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + complex q__1; + + /* Local variables */ + integer np1x2, i__, j, k, l; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer nx2; + + +/* -- 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 - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_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 (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRTTF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + if (normaltransr) { + arf[0].r = a[0].r, arf[0].i = a[0].i; + } else { + r_cnjg(&q__1, a); + arf[0].r = q__1.r, arf[0].i = q__1.i; + } + } + return 0; + } + +/* Size of array ARF(1:2,0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = TRUE_; + if (! lower) { + nx2 = *n + *n; + } + } + + 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); lda=n */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[n2 + j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + j * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + } + + } 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); lda=n */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + j * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + i__3 = ij; + r_cnjg(&q__1, &a[j - n1 + l * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + ij -= nx2; + } + + } + + } 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 */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + (n1 + j) * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + } + + } 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 */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + j * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + i__3 = ij; + r_cnjg(&q__1, &a[n2 + j + l * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + } + + } + + } + + } 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); lda=n+1 */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[k + j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + j * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + } + + } 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); lda=n+1 */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + j * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + i__3 = ij; + r_cnjg(&q__1, &a[j - k + l * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'C' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) */ +/* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : */ +/* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + i__2 = ij; + i__3 = i__ + j * a_dim1; + arf[i__2].r = a[i__3].r, arf[i__2].i = a[i__3].i; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + (k + 1 + j) * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) */ +/* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) */ +/* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + i__3 = ij; + r_cnjg(&q__1, &a[j + i__ * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + i__3 = ij; + i__4 = i__ + j * a_dim1; + arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + i__3 = ij; + r_cnjg(&q__1, &a[k + 1 + j + l * a_dim1]); + arf[i__3].r = q__1.r, arf[i__3].i = q__1.i; + ++ij; + } + } + +/* Note that here J = K-1 */ + + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = ij; + i__3 = i__ + j * a_dim1; + arf[i__2].r = a[i__3].r, arf[i__2].i = a[i__3].i; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of CTRTTF */ + +} /* ctrttf_ */ + diff --git a/lapack-netlib/SRC/ctrttp.c b/lapack-netlib/SRC/ctrttp.c new file mode 100644 index 000000000..216c32f94 --- /dev/null +++ b/lapack-netlib/SRC/ctrttp.c @@ -0,0 +1,571 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed for +mat (TP). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTRTTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N, LDA */ +/* COMPLEX A( LDA, * ), AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTRTTP copies a triangular matrix A from full format (TR) to standard */ +/* > packed format (TP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices AP and A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the triangular 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[out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension ( N*(N+1)/2 ), */ +/* > On exit, 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[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 ctrttp_(char *uplo, integer *n, complex *a, integer *lda, + complex *ap, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, k; + extern logical lsame_(char *, char *); + 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ap; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRTTP", &i__1, (ftnlen)6); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + i__3 = k; + i__4 = i__ + j * a_dim1; + ap[i__3].r = a[i__4].r, ap[i__3].i = a[i__4].i; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + i__3 = k; + i__4 = i__ + j * a_dim1; + ap[i__3].r = a[i__4].r, ap[i__3].i = a[i__4].i; + } + } + } + + + return 0; + +/* End of CTRTTP */ + +} /* ctrttp_ */ + diff --git a/lapack-netlib/SRC/ctzrzf.c b/lapack-netlib/SRC/ctzrzf.c new file mode 100644 index 000000000..00b569385 --- /dev/null +++ b/lapack-netlib/SRC/ctzrzf.c @@ -0,0 +1,739 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTZRZF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTZRZF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */ +/* > to upper triangular form by means of unitary transformations. */ +/* > */ +/* > The upper trapezoidal matrix A is factored as */ +/* > */ +/* > A = ( R 0 ) * Z, */ +/* > */ +/* > where Z is an N-by-N unitary matrix and R is an M-by-M upper */ +/* > triangular matrix. */ +/* > \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. */ +/* > \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 M+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 (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= M*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The N-by-N matrix Z can be computed by */ +/* > */ +/* > Z = Z(1)*Z(2)* ... *Z(M) */ +/* > */ +/* > where each N-by-N Z(k) is given by */ +/* > */ +/* > Z(k) = I - tau(k)*v(k)*v(k)**H */ +/* > */ +/* > with v(k) is the kth row vector of the M-by-N matrix */ +/* > */ +/* > V = ( I A(:,M+1:N) ) */ +/* > */ +/* > I is the M-by-M identity matrix, A(:,M+1:N) */ +/* > is the output stored in A on exit from DTZRZF, */ +/* > and tau(k) is the kth element of the array TAU. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctzrzf_(integer *m, integer *n, complex *a, integer *lda, + complex *tau, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, nbmin, m1, ib, nb, ki, kk, mu, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), clarzb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int clarzt_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), clatrz_(integer *, integer *, integer *, complex *, + integer *, complex *, complex *); + integer lwkmin, ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + + if (*info == 0) { + if (*m == 0 || *m == *n) { + lwkopt = 1; + lwkmin = 1; + } else { + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *m * nb; + lwkmin = f2cmax(1,*m); + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + + if (*lwork < lwkmin && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTZRZF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + 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; + } + + nbmin = 2; + nx = 1; + iws = *m; + if (nb > 1 && nb < *m) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "CGERQF", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *m) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CGERQF", " ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *m && nx < *m) { + +/* Use blocked code initially. */ +/* The last kk rows are handled by the block method. */ + +/* Computing MIN */ + i__1 = *m + 1; + m1 = f2cmin(i__1,*n); + ki = (*m - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *m, i__2 = ki + nb; + kk = f2cmin(i__1,i__2); + + i__1 = *m - kk + 1; + i__2 = -nb; + for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; + i__ += i__2) { +/* Computing MIN */ + i__3 = *m - i__ + 1; + ib = f2cmin(i__3,nb); + +/* Compute the TZ factorization of the current block */ +/* A(i:i+ib-1,i:n) */ + + i__3 = *n - i__ + 1; + i__4 = *n - *m; + clatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1]); + if (i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *n - *m; + clarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(1:i-1,i:n) from the right */ + + i__3 = i__ - 1; + i__4 = *n - i__ + 1; + i__5 = *n - *m; + clarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3, + &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1], + &ldwork) + ; + } +/* L20: */ + } + mu = i__ + nb - 1; + } else { + mu = *m; + } + +/* Use unblocked code to factor the last or only block */ + + if (mu > 0) { + i__2 = *n - *m; + clatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]); + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CTZRZF */ + +} /* ctzrzf_ */ + diff --git a/lapack-netlib/SRC/cunbdb.c b/lapack-netlib/SRC/cunbdb.c new file mode 100644 index 000000000..3fb47141e --- /dev/null +++ b/lapack-netlib/SRC/cunbdb.c @@ -0,0 +1,1305 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNBDB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNBDB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, */ +/* X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, */ +/* TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) */ + +/* CHARACTER SIGNS, TRANS */ +/* INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, */ +/* $ Q */ +/* REAL PHI( * ), THETA( * ) */ +/* COMPLEX TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), */ +/* $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), */ +/* $ X21( LDX21, * ), X22( LDX22, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNBDB simultaneously bidiagonalizes the blocks of an M-by-M */ +/* > partitioned unitary matrix X: */ +/* > */ +/* > [ B11 | B12 0 0 ] */ +/* > [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H */ +/* > X = [-----------] = [---------] [----------------] [---------] . */ +/* > [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ] */ +/* > [ 0 | 0 0 I ] */ +/* > */ +/* > X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is */ +/* > not the case, then X must be transposed and/or permuted. This can be */ +/* > done in constant time using the TRANS and SIGNS options. See CUNCSD */ +/* > for details.) */ +/* > */ +/* > The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by- */ +/* > (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are */ +/* > represented implicitly by Householder vectors. */ +/* > */ +/* > B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented */ +/* > implicitly by angles THETA, PHI. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER */ +/* > = 'T': X, U1, U2, V1T, and V2T are stored in row-major */ +/* > order; */ +/* > otherwise: X, U1, U2, V1T, and V2T are stored in column- */ +/* > major order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIGNS */ +/* > \verbatim */ +/* > SIGNS is CHARACTER */ +/* > = 'O': The lower-left block is made nonpositive (the */ +/* > "other" convention); */ +/* > otherwise: The upper-right block is made nonpositive (the */ +/* > "default" convention). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows and columns in X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11 and X12. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= */ +/* > MIN(P,M-P,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is COMPLEX array, dimension (LDX11,Q) */ +/* > On entry, the top-left block of the unitary matrix to be */ +/* > reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the columns of tril(X11) specify reflectors for P1, */ +/* > the rows of triu(X11,1) specify reflectors for Q1; */ +/* > else TRANS = 'T', and */ +/* > the rows of triu(X11) specify reflectors for P1, */ +/* > the columns of tril(X11,-1) specify reflectors for Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. If TRANS = 'N', then LDX11 >= */ +/* > P; else LDX11 >= Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X12 */ +/* > \verbatim */ +/* > X12 is COMPLEX array, dimension (LDX12,M-Q) */ +/* > On entry, the top-right block of the unitary matrix to */ +/* > be reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the rows of triu(X12) specify the first P reflectors for */ +/* > Q2; */ +/* > else TRANS = 'T', and */ +/* > the columns of tril(X12) specify the first P reflectors */ +/* > for Q2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX12 */ +/* > \verbatim */ +/* > LDX12 is INTEGER */ +/* > The leading dimension of X12. If TRANS = 'N', then LDX12 >= */ +/* > P; else LDX11 >= M-Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is COMPLEX array, dimension (LDX21,Q) */ +/* > On entry, the bottom-left block of the unitary matrix to */ +/* > be reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the columns of tril(X21) specify reflectors for P2; */ +/* > else TRANS = 'T', and */ +/* > the rows of triu(X21) specify reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X21. If TRANS = 'N', then LDX21 >= */ +/* > M-P; else LDX21 >= Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X22 */ +/* > \verbatim */ +/* > X22 is COMPLEX array, dimension (LDX22,M-Q) */ +/* > On entry, the bottom-right block of the unitary matrix to */ +/* > be reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last */ +/* > M-P-Q reflectors for Q2, */ +/* > else TRANS = 'T', and */ +/* > the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last */ +/* > M-P-Q reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX22 */ +/* > \verbatim */ +/* > LDX22 is INTEGER */ +/* > The leading dimension of X22. If TRANS = 'N', then LDX22 >= */ +/* > M-P; else LDX22 >= M-Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (Q) */ +/* > The entries of the bidiagonal blocks B11, B12, B21, B22 can */ +/* > be computed from the angles THETA and PHI. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PHI */ +/* > \verbatim */ +/* > PHI is REAL array, dimension (Q-1) */ +/* > The entries of the bidiagonal blocks B11, B12, B21, B22 can */ +/* > be computed from the angles THETA and PHI. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP1 */ +/* > \verbatim */ +/* > TAUP1 is COMPLEX array, dimension (P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP2 */ +/* > \verbatim */ +/* > TAUP2 is COMPLEX array, dimension (M-P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ1 */ +/* > \verbatim */ +/* > TAUQ1 is COMPLEX array, dimension (Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ2 */ +/* > \verbatim */ +/* > TAUQ2 is COMPLEX array, dimension (M-Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= M-Q. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The bidiagonal blocks B11, B12, B21, and B22 are represented */ +/* > implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ..., */ +/* > PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are */ +/* > lower bidiagonal. Every entry in each bidiagonal band is a product */ +/* > of a sine or cosine of a THETA with a sine or cosine of a PHI. See */ +/* > [1] or CUNCSD for details. */ +/* > */ +/* > P1, P2, Q1, and Q2 are represented as products of elementary */ +/* > reflectors. See CUNCSD for details on generating P1, P2, Q1, and Q2 */ +/* > using CUNGQR and CUNGLQ. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cunbdb_(char *trans, char *signs, integer *m, integer *p, + integer *q, complex *x11, integer *ldx11, complex *x12, integer * + ldx12, complex *x21, integer *ldx21, complex *x22, integer *ldx22, + real *theta, real *phi, complex *taup1, complex *taup2, complex * + tauq1, complex *tauq2, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer x11_dim1, x11_offset, x12_dim1, x12_offset, x21_dim1, x21_offset, + x22_dim1, x22_offset, i__1, i__2, i__3; + real r__1; + complex q__1; + + /* Local variables */ + logical colmajor; + integer lworkmin, lworkopt, i__; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), clarf_(char *, integer *, integer *, complex *, + integer *, complex *, complex *, integer *, complex *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + real z1, z2, z3, z4; + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical lquery; + extern /* Subroutine */ int clarfgp_(integer *, complex *, complex *, + integer *, complex *); + + +/* -- 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 input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x12_dim1 = *ldx12; + x12_offset = 1 + x12_dim1 * 1; + x12 -= x12_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + x22_dim1 = *ldx22; + x22_offset = 1 + x22_dim1 * 1; + x22 -= x22_offset; + --theta; + --phi; + --taup1; + --taup2; + --tauq1; + --tauq2; + --work; + + /* Function Body */ + *info = 0; + colmajor = ! lsame_(trans, "T"); + if (! lsame_(signs, "O")) { + z1 = 1.f; + z2 = 1.f; + z3 = 1.f; + z4 = 1.f; + } else { + z1 = 1.f; + z2 = -1.f; + z3 = 1.f; + z4 = -1.f; + } + lquery = *lwork == -1; + + if (*m < 0) { + *info = -3; + } else if (*p < 0 || *p > *m) { + *info = -4; + } else if (*q < 0 || *q > *p || *q > *m - *p || *q > *m - *q) { + *info = -5; + } else if (colmajor && *ldx11 < f2cmax(1,*p)) { + *info = -7; + } else if (! colmajor && *ldx11 < f2cmax(1,*q)) { + *info = -7; + } else if (colmajor && *ldx12 < f2cmax(1,*p)) { + *info = -9; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + if (! colmajor && *ldx12 < f2cmax(i__1,i__2)) { + *info = -9; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (colmajor && *ldx21 < f2cmax(i__1,i__2)) { + *info = -11; + } else if (! colmajor && *ldx21 < f2cmax(1,*q)) { + *info = -11; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (colmajor && *ldx22 < f2cmax(i__1,i__2)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + if (! colmajor && *ldx22 < f2cmax(i__1,i__2)) { + *info = -13; + } + } + } + } + } + +/* Compute workspace */ + + if (*info == 0) { + lworkopt = *m - *q; + lworkmin = *m - *q; + work[1].r = (real) lworkopt, work[1].i = 0.f; + if (*lwork < lworkmin && ! lquery) { + *info = -21; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("xORBDB", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Handle column-major and row-major separately */ + + if (colmajor) { + +/* Reduce columns 1, ..., Q of X11, X12, X21, and X22 */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (i__ == 1) { + i__2 = *p - i__ + 1; + q__1.r = z1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x11[i__ + i__ * x11_dim1], &c__1); + } else { + i__2 = *p - i__ + 1; + r__1 = z1 * cos(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x11[i__ + i__ * x11_dim1], &c__1); + i__2 = *p - i__ + 1; + r__1 = -z1 * z3 * z4 * sin(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x12[i__ + (i__ - 1) * x12_dim1], &c__1, + &x11[i__ + i__ * x11_dim1], &c__1); + } + if (i__ == 1) { + i__2 = *m - *p - i__ + 1; + q__1.r = z2, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x21[i__ + i__ * x21_dim1], &c__1); + } else { + i__2 = *m - *p - i__ + 1; + r__1 = z2 * cos(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x21[i__ + i__ * x21_dim1], &c__1); + i__2 = *m - *p - i__ + 1; + r__1 = -z2 * z3 * z4 * sin(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x22[i__ + (i__ - 1) * x22_dim1], &c__1, + &x21[i__ + i__ * x21_dim1], &c__1); + } + + i__2 = *m - *p - i__ + 1; + i__3 = *p - i__ + 1; + theta[i__] = atan2(scnrm2_(&i__2, &x21[i__ + i__ * x21_dim1], & + c__1), scnrm2_(&i__3, &x11[i__ + i__ * x11_dim1], &c__1)); + + if (*p > i__) { + i__2 = *p - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + 1 + + i__ * x11_dim1], &c__1, &taup1[i__]); + } else if (*p == i__) { + i__2 = *p - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + i__ * + x11_dim1], &c__1, &taup1[i__]); + } + i__2 = i__ + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + if (*m - *p > i__) { + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + 1 + + i__ * x21_dim1], &c__1, &taup2[i__]); + } else if (*m - *p == i__) { + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + i__ * + x21_dim1], &c__1, &taup2[i__]); + } + i__2 = i__ + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + + if (*q > i__) { + i__2 = *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, & + q__1, &x11[i__ + (i__ + 1) * x11_dim1], ldx11, &work[ + 1]); + i__2 = *m - *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup2[i__]); + clarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, & + q__1, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, &work[ + 1]); + } + if (*m - *q + 1 > i__) { + i__2 = *p - i__ + 1; + i__3 = *m - *q - i__ + 1; + r_cnjg(&q__1, &taup1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, & + q__1, &x12[i__ + i__ * x12_dim1], ldx12, &work[1]); + i__2 = *m - *p - i__ + 1; + i__3 = *m - *q - i__ + 1; + r_cnjg(&q__1, &taup2[i__]); + clarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, & + q__1, &x22[i__ + i__ * x22_dim1], ldx22, &work[1]); + } + + if (i__ < *q) { + i__2 = *q - i__; + r__1 = -z1 * z3 * sin(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x11[i__ + (i__ + 1) * x11_dim1], ldx11); + i__2 = *q - i__; + r__1 = z2 * z3 * cos(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, + &x11[i__ + (i__ + 1) * x11_dim1], ldx11); + } + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4 * sin(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x12[i__ + i__ * x12_dim1], ldx12); + i__2 = *m - *q - i__ + 1; + r__1 = z2 * z4 * cos(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x22[i__ + i__ * x22_dim1], ldx22, &x12[i__ + + i__ * x12_dim1], ldx12); + + if (i__ < *q) { + i__2 = *q - i__; + i__3 = *m - *q - i__ + 1; + phi[i__] = atan2(scnrm2_(&i__2, &x11[i__ + (i__ + 1) * + x11_dim1], ldx11), scnrm2_(&i__3, &x12[i__ + i__ * + x12_dim1], ldx12)); + } + + if (i__ < *q) { + i__2 = *q - i__; + clacgv_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], ldx11); + if (i__ == *q - 1) { + i__2 = *q - i__; + clarfgp_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], &x11[ + i__ + (i__ + 1) * x11_dim1], ldx11, &tauq1[i__]); + } else { + i__2 = *q - i__; + clarfgp_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], &x11[ + i__ + (i__ + 2) * x11_dim1], ldx11, &tauq1[i__]); + } + i__2 = i__ + (i__ + 1) * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + } + if (*m - *q + 1 > i__) { + i__2 = *m - *q - i__ + 1; + clacgv_(&i__2, &x12[i__ + i__ * x12_dim1], ldx12); + if (*m - *q == i__) { + i__2 = *m - *q - i__ + 1; + clarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + + i__ * x12_dim1], ldx12, &tauq2[i__]); + } else { + i__2 = *m - *q - i__ + 1; + clarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + ( + i__ + 1) * x12_dim1], ldx12, &tauq2[i__]); + } + } + i__2 = i__ + i__ * x12_dim1; + x12[i__2].r = 1.f, x12[i__2].i = 0.f; + + if (i__ < *q) { + i__2 = *p - i__; + i__3 = *q - i__; + clarf_("R", &i__2, &i__3, &x11[i__ + (i__ + 1) * x11_dim1], + ldx11, &tauq1[i__], &x11[i__ + 1 + (i__ + 1) * + x11_dim1], ldx11, &work[1]); + i__2 = *m - *p - i__; + i__3 = *q - i__; + clarf_("R", &i__2, &i__3, &x11[i__ + (i__ + 1) * x11_dim1], + ldx11, &tauq1[i__], &x21[i__ + 1 + (i__ + 1) * + x21_dim1], ldx21, &work[1]); + } + if (*p > i__) { + i__2 = *p - i__; + i__3 = *m - *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x12[i__ + 1 + i__ * x12_dim1], ldx12, & + work[1]); + } + if (*m - *p > i__) { + i__2 = *m - *p - i__; + i__3 = *m - *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x22[i__ + 1 + i__ * x22_dim1], ldx22, & + work[1]); + } + + if (i__ < *q) { + i__2 = *q - i__; + clacgv_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], ldx11); + } + i__2 = *m - *q - i__ + 1; + clacgv_(&i__2, &x12[i__ + i__ * x12_dim1], ldx12); + + } + +/* Reduce columns Q + 1, ..., P of X12, X22 */ + + i__1 = *p; + for (i__ = *q + 1; i__ <= i__1; ++i__) { + + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4; + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x12[i__ + i__ * x12_dim1], ldx12); + i__2 = *m - *q - i__ + 1; + clacgv_(&i__2, &x12[i__ + i__ * x12_dim1], ldx12); + if (i__ >= *m - *q) { + i__2 = *m - *q - i__ + 1; + clarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + i__ * + x12_dim1], ldx12, &tauq2[i__]); + } else { + i__2 = *m - *q - i__ + 1; + clarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + (i__ + + 1) * x12_dim1], ldx12, &tauq2[i__]); + } + i__2 = i__ + i__ * x12_dim1; + x12[i__2].r = 1.f, x12[i__2].i = 0.f; + + if (*p > i__) { + i__2 = *p - i__; + i__3 = *m - *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x12[i__ + 1 + i__ * x12_dim1], ldx12, & + work[1]); + } + if (*m - *p - *q >= 1) { + i__2 = *m - *p - *q; + i__3 = *m - *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x22[*q + 1 + i__ * x22_dim1], ldx22, & + work[1]); + } + + i__2 = *m - *q - i__ + 1; + clacgv_(&i__2, &x12[i__ + i__ * x12_dim1], ldx12); + + } + +/* Reduce columns P + 1, ..., M - Q of X12, X22 */ + + i__1 = *m - *p - *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + i__2 = *m - *p - *q - i__ + 1; + r__1 = z2 * z4; + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x22[*q + i__ + (*p + i__) * x22_dim1], + ldx22); + i__2 = *m - *p - *q - i__ + 1; + clacgv_(&i__2, &x22[*q + i__ + (*p + i__) * x22_dim1], ldx22); + i__2 = *m - *p - *q - i__ + 1; + clarfgp_(&i__2, &x22[*q + i__ + (*p + i__) * x22_dim1], &x22[*q + + i__ + (*p + i__ + 1) * x22_dim1], ldx22, &tauq2[*p + i__]) + ; + i__2 = *q + i__ + (*p + i__) * x22_dim1; + x22[i__2].r = 1.f, x22[i__2].i = 0.f; + i__2 = *m - *p - *q - i__; + i__3 = *m - *p - *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x22[*q + i__ + (*p + i__) * x22_dim1], + ldx22, &tauq2[*p + i__], &x22[*q + i__ + 1 + (*p + i__) * + x22_dim1], ldx22, &work[1]); + + i__2 = *m - *p - *q - i__ + 1; + clacgv_(&i__2, &x22[*q + i__ + (*p + i__) * x22_dim1], ldx22); + + } + + } else { + +/* Reduce columns 1, ..., Q of X11, X12, X21, X22 */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (i__ == 1) { + i__2 = *p - i__ + 1; + q__1.r = z1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x11[i__ + i__ * x11_dim1], ldx11); + } else { + i__2 = *p - i__ + 1; + r__1 = z1 * cos(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x11[i__ + i__ * x11_dim1], ldx11); + i__2 = *p - i__ + 1; + r__1 = -z1 * z3 * z4 * sin(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x12[i__ - 1 + i__ * x12_dim1], ldx12, & + x11[i__ + i__ * x11_dim1], ldx11); + } + if (i__ == 1) { + i__2 = *m - *p - i__ + 1; + q__1.r = z2, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x21[i__ + i__ * x21_dim1], ldx21); + } else { + i__2 = *m - *p - i__ + 1; + r__1 = z2 * cos(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x21[i__ + i__ * x21_dim1], ldx21); + i__2 = *m - *p - i__ + 1; + r__1 = -z2 * z3 * z4 * sin(phi[i__ - 1]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x22[i__ - 1 + i__ * x22_dim1], ldx22, & + x21[i__ + i__ * x21_dim1], ldx21); + } + + i__2 = *m - *p - i__ + 1; + i__3 = *p - i__ + 1; + theta[i__] = atan2(scnrm2_(&i__2, &x21[i__ + i__ * x21_dim1], + ldx21), scnrm2_(&i__3, &x11[i__ + i__ * x11_dim1], ldx11)) + ; + + i__2 = *p - i__ + 1; + clacgv_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11); + i__2 = *m - *p - i__ + 1; + clacgv_(&i__2, &x21[i__ + i__ * x21_dim1], ldx21); + + i__2 = *p - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + (i__ + 1) * + x11_dim1], ldx11, &taup1[i__]); + i__2 = i__ + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + if (i__ == *m - *p) { + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + i__ * + x21_dim1], ldx21, &taup2[i__]); + } else { + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + (i__ + + 1) * x21_dim1], ldx21, &taup2[i__]); + } + i__2 = i__ + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + + i__2 = *q - i__; + i__3 = *p - i__ + 1; + clarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, & + taup1[i__], &x11[i__ + 1 + i__ * x11_dim1], ldx11, &work[ + 1]); + i__2 = *m - *q - i__ + 1; + i__3 = *p - i__ + 1; + clarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, & + taup1[i__], &x12[i__ + i__ * x12_dim1], ldx12, &work[1]); + i__2 = *q - i__; + i__3 = *m - *p - i__ + 1; + clarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, & + taup2[i__], &x21[i__ + 1 + i__ * x21_dim1], ldx21, &work[ + 1]); + i__2 = *m - *q - i__ + 1; + i__3 = *m - *p - i__ + 1; + clarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, & + taup2[i__], &x22[i__ + i__ * x22_dim1], ldx22, &work[1]); + + i__2 = *p - i__ + 1; + clacgv_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11); + i__2 = *m - *p - i__ + 1; + clacgv_(&i__2, &x21[i__ + i__ * x21_dim1], ldx21); + + if (i__ < *q) { + i__2 = *q - i__; + r__1 = -z1 * z3 * sin(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x11[i__ + 1 + i__ * x11_dim1], &c__1); + i__2 = *q - i__; + r__1 = z2 * z3 * cos(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x21[i__ + 1 + i__ * x21_dim1], &c__1, & + x11[i__ + 1 + i__ * x11_dim1], &c__1); + } + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4 * sin(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x12[i__ + i__ * x12_dim1], &c__1); + i__2 = *m - *q - i__ + 1; + r__1 = z2 * z4 * cos(theta[i__]); + q__1.r = r__1, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &x22[i__ + i__ * x22_dim1], &c__1, &x12[i__ + + i__ * x12_dim1], &c__1); + + if (i__ < *q) { + i__2 = *q - i__; + i__3 = *m - *q - i__ + 1; + phi[i__] = atan2(scnrm2_(&i__2, &x11[i__ + 1 + i__ * x11_dim1] + , &c__1), scnrm2_(&i__3, &x12[i__ + i__ * x12_dim1], & + c__1)); + } + + if (i__ < *q) { + i__2 = *q - i__; + clarfgp_(&i__2, &x11[i__ + 1 + i__ * x11_dim1], &x11[i__ + 2 + + i__ * x11_dim1], &c__1, &tauq1[i__]); + i__2 = i__ + 1 + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + } + i__2 = *m - *q - i__ + 1; + clarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + 1 + i__ * + x12_dim1], &c__1, &tauq2[i__]); + i__2 = i__ + i__ * x12_dim1; + x12[i__2].r = 1.f, x12[i__2].i = 0.f; + + if (i__ < *q) { + i__2 = *q - i__; + i__3 = *p - i__; + r_cnjg(&q__1, &tauq1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + 1 + i__ * x11_dim1], & + c__1, &q__1, &x11[i__ + 1 + (i__ + 1) * x11_dim1], + ldx11, &work[1]); + i__2 = *q - i__; + i__3 = *m - *p - i__; + r_cnjg(&q__1, &tauq1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + 1 + i__ * x11_dim1], & + c__1, &q__1, &x21[i__ + 1 + (i__ + 1) * x21_dim1], + ldx21, &work[1]); + } + i__2 = *m - *q - i__ + 1; + i__3 = *p - i__; + r_cnjg(&q__1, &tauq2[i__]); + clarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + q__1, &x12[i__ + (i__ + 1) * x12_dim1], ldx12, &work[1]); + if (*m - *p > i__) { + i__2 = *m - *q - i__ + 1; + i__3 = *m - *p - i__; + r_cnjg(&q__1, &tauq2[i__]); + clarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + q__1, &x22[i__ + (i__ + 1) * x22_dim1], ldx22, &work[ + 1]); + } + } + +/* Reduce columns Q + 1, ..., P of X12, X22 */ + + i__1 = *p; + for (i__ = *q + 1; i__ <= i__1; ++i__) { + + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4; + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x12[i__ + i__ * x12_dim1], &c__1); + i__2 = *m - *q - i__ + 1; + clarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + 1 + i__ * + x12_dim1], &c__1, &tauq2[i__]); + i__2 = i__ + i__ * x12_dim1; + x12[i__2].r = 1.f, x12[i__2].i = 0.f; + + if (*p > i__) { + i__2 = *m - *q - i__ + 1; + i__3 = *p - i__; + r_cnjg(&q__1, &tauq2[i__]); + clarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + q__1, &x12[i__ + (i__ + 1) * x12_dim1], ldx12, &work[ + 1]); + } + if (*m - *p - *q >= 1) { + i__2 = *m - *q - i__ + 1; + i__3 = *m - *p - *q; + r_cnjg(&q__1, &tauq2[i__]); + clarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + q__1, &x22[i__ + (*q + 1) * x22_dim1], ldx22, &work[1] + ); + } + + } + +/* Reduce columns P + 1, ..., M - Q of X12, X22 */ + + i__1 = *m - *p - *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + i__2 = *m - *p - *q - i__ + 1; + r__1 = z2 * z4; + q__1.r = r__1, q__1.i = 0.f; + cscal_(&i__2, &q__1, &x22[*p + i__ + (*q + i__) * x22_dim1], & + c__1); + i__2 = *m - *p - *q - i__ + 1; + clarfgp_(&i__2, &x22[*p + i__ + (*q + i__) * x22_dim1], &x22[*p + + i__ + 1 + (*q + i__) * x22_dim1], &c__1, &tauq2[*p + i__]) + ; + i__2 = *p + i__ + (*q + i__) * x22_dim1; + x22[i__2].r = 1.f, x22[i__2].i = 0.f; + if (*m - *p - *q != i__) { + i__2 = *m - *p - *q - i__ + 1; + i__3 = *m - *p - *q - i__; + r_cnjg(&q__1, &tauq2[*p + i__]); + clarf_("L", &i__2, &i__3, &x22[*p + i__ + (*q + i__) * + x22_dim1], &c__1, &q__1, &x22[*p + i__ + (*q + i__ + + 1) * x22_dim1], ldx22, &work[1]); + } + } + + } + + return 0; + +/* End of CUNBDB */ + +} /* cunbdb_ */ + diff --git a/lapack-netlib/SRC/cunbdb1.c b/lapack-netlib/SRC/cunbdb1.c new file mode 100644 index 000000000..b3af7be52 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb1.c @@ -0,0 +1,779 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNBDB1 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNBDB1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, */ +/* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 */ +/* REAL PHI(*), THETA(*) */ +/* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), */ +/* $ X11(LDX11,*), X21(LDX21,*) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* >\verbatim */ +/* > */ +/* > CUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny */ +/* > matrix X with orthonomal columns: */ +/* > */ +/* > [ B11 ] */ +/* > [ X11 ] [ P1 | ] [ 0 ] */ +/* > [-----] = [---------] [-----] Q1**T . */ +/* > [ X21 ] [ | P2 ] [ B21 ] */ +/* > [ 0 ] */ +/* > */ +/* > X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, */ +/* > M-P, or M-Q. Routines CUNBDB2, CUNBDB3, and CUNBDB4 handle cases in */ +/* > which Q is not the minimum dimension. */ +/* > */ +/* > The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), */ +/* > and (M-Q)-by-(M-Q), respectively. They are represented implicitly by */ +/* > Householder vectors. */ +/* > */ +/* > B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by */ +/* > angles THETA, PHI. */ +/* > */ +/* >\endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows X11 plus the number of rows in X21. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= */ +/* > MIN(P,M-P,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is COMPLEX array, dimension (LDX11,Q) */ +/* > On entry, the top block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X11) specify reflectors for P1 and */ +/* > the rows of triu(X11,1) specify reflectors for Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. LDX11 >= P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is COMPLEX array, dimension (LDX21,Q) */ +/* > On entry, the bottom block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X21) specify reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X21. LDX21 >= M-P. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (Q) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PHI */ +/* > \verbatim */ +/* > PHI is REAL array, dimension (Q-1) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP1 */ +/* > \verbatim */ +/* > TAUP1 is COMPLEX array, dimension (P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP2 */ +/* > \verbatim */ +/* > TAUP2 is COMPLEX array, dimension (M-P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ1 */ +/* > \verbatim */ +/* > TAUQ1 is COMPLEX array, dimension (Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= M-Q. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date July 2012 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > \verbatim */ +/* > */ +/* > The upper-bidiagonal blocks B11, B21 are represented implicitly by */ +/* > angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry */ +/* > in each bidiagonal band is a product of a sine or cosine of a THETA */ +/* > with a sine or cosine of a PHI. See [1] or CUNCSD for details. */ +/* > */ +/* > P1, P2, and Q1 are represented as products of elementary reflectors. */ +/* > See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR */ +/* > and CUNGLQ. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cunbdb1_(integer *m, integer *p, integer *q, complex * + x11, integer *ldx11, complex *x21, integer *ldx21, real *theta, real * + phi, complex *taup1, complex *taup2, complex *tauq1, complex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer x11_dim1, x11_offset, x21_dim1, x21_offset, i__1, i__2, i__3, + i__4; + real r__1, r__2; + complex q__1; + + /* Local variables */ + integer lworkmin, lworkopt; + real c__; + integer i__; + real s; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *); + integer ilarf, llarf, childinfo; + extern /* Subroutine */ int csrot_(integer *, complex *, integer *, + complex *, integer *, real *, real *); + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical lquery; + extern /* Subroutine */ int cunbdb5_(integer *, integer *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, integer *); + integer iorbdb5, lorbdb5; + extern /* Subroutine */ int clarfgp_(integer *, complex *, complex *, + integer *, complex *); + + +/* -- 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..-- */ +/* July 2012 */ + + +/* ==================================================================== */ + + +/* Test input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + --theta; + --phi; + --taup1; + --taup2; + --tauq1; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*p < *q || *m - *p < *q) { + *info = -2; + } else if (*q < 0 || *m - *q < *q) { + *info = -3; + } else if (*ldx11 < f2cmax(1,*p)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (*ldx21 < f2cmax(i__1,i__2)) { + *info = -7; + } + } + +/* Compute workspace */ + + if (*info == 0) { + ilarf = 2; +/* Computing MAX */ + i__1 = *p - 1, i__2 = *m - *p - 1, i__1 = f2cmax(i__1,i__2), i__2 = *q - + 1; + llarf = f2cmax(i__1,i__2); + iorbdb5 = 2; + lorbdb5 = *q - 2; +/* Computing MAX */ + i__1 = ilarf + llarf - 1, i__2 = iorbdb5 + lorbdb5 - 1; + lworkopt = f2cmax(i__1,i__2); + lworkmin = lworkopt; + work[1].r = (real) lworkopt, work[1].i = 0.f; + if (*lwork < lworkmin && ! lquery) { + *info = -14; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNBDB1", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Reduce columns 1, ..., Q of X11 and X21 */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + i__2 = *p - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + 1 + i__ * + x11_dim1], &c__1, &taup1[i__]); + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + 1 + i__ * + x21_dim1], &c__1, &taup2[i__]); + theta[i__] = atan2((real) x21[i__ + i__ * x21_dim1].r, (real) x11[i__ + + i__ * x11_dim1].r); + c__ = cos(theta[i__]); + s = sin(theta[i__]); + i__2 = i__ + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + i__2 = i__ + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, &q__1, & + x11[i__ + (i__ + 1) * x11_dim1], ldx11, &work[ilarf]); + i__2 = *m - *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup2[i__]); + clarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, &q__1, & + x21[i__ + (i__ + 1) * x21_dim1], ldx21, &work[ilarf]); + + if (i__ < *q) { + i__2 = *q - i__; + csrot_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], ldx11, &x21[i__ + + (i__ + 1) * x21_dim1], ldx21, &c__, &s); + i__2 = *q - i__; + clacgv_(&i__2, &x21[i__ + (i__ + 1) * x21_dim1], ldx21); + i__2 = *q - i__; + clarfgp_(&i__2, &x21[i__ + (i__ + 1) * x21_dim1], &x21[i__ + (i__ + + 2) * x21_dim1], ldx21, &tauq1[i__]); + i__2 = i__ + (i__ + 1) * x21_dim1; + s = x21[i__2].r; + i__2 = i__ + (i__ + 1) * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *p - i__; + i__3 = *q - i__; + clarf_("R", &i__2, &i__3, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, + &tauq1[i__], &x11[i__ + 1 + (i__ + 1) * x11_dim1], ldx11, + &work[ilarf]); + i__2 = *m - *p - i__; + i__3 = *q - i__; + clarf_("R", &i__2, &i__3, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, + &tauq1[i__], &x21[i__ + 1 + (i__ + 1) * x21_dim1], ldx21, + &work[ilarf]); + i__2 = *q - i__; + clacgv_(&i__2, &x21[i__ + (i__ + 1) * x21_dim1], ldx21); + i__2 = *p - i__; +/* Computing 2nd power */ + r__1 = scnrm2_(&i__2, &x11[i__ + 1 + (i__ + 1) * x11_dim1], &c__1) + ; + i__3 = *m - *p - i__; +/* Computing 2nd power */ + r__2 = scnrm2_(&i__3, &x21[i__ + 1 + (i__ + 1) * x21_dim1], &c__1) + ; + c__ = sqrt(r__1 * r__1 + r__2 * r__2); + phi[i__] = atan2(s, c__); + i__2 = *p - i__; + i__3 = *m - *p - i__; + i__4 = *q - i__ - 1; + cunbdb5_(&i__2, &i__3, &i__4, &x11[i__ + 1 + (i__ + 1) * x11_dim1] + , &c__1, &x21[i__ + 1 + (i__ + 1) * x21_dim1], &c__1, & + x11[i__ + 1 + (i__ + 2) * x11_dim1], ldx11, &x21[i__ + 1 + + (i__ + 2) * x21_dim1], ldx21, &work[iorbdb5], &lorbdb5, + &childinfo); + } + + } + + return 0; + +/* End of CUNBDB1 */ + +} /* cunbdb1_ */ + diff --git a/lapack-netlib/SRC/cunbdb2.c b/lapack-netlib/SRC/cunbdb2.c new file mode 100644 index 000000000..bd3a215b3 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb2.c @@ -0,0 +1,797 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNBDB2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNBDB2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, */ +/* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 */ +/* REAL PHI(*), THETA(*) */ +/* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), */ +/* $ X11(LDX11,*), X21(LDX21,*) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* >\verbatim */ +/* > */ +/* > CUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny */ +/* > matrix X with orthonomal columns: */ +/* > */ +/* > [ B11 ] */ +/* > [ X11 ] [ P1 | ] [ 0 ] */ +/* > [-----] = [---------] [-----] Q1**T . */ +/* > [ X21 ] [ | P2 ] [ B21 ] */ +/* > [ 0 ] */ +/* > */ +/* > X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, */ +/* > Q, or M-Q. Routines CUNBDB1, CUNBDB3, and CUNBDB4 handle cases in */ +/* > which P is not the minimum dimension. */ +/* > */ +/* > The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), */ +/* > and (M-Q)-by-(M-Q), respectively. They are represented implicitly by */ +/* > Householder vectors. */ +/* > */ +/* > B11 and B12 are P-by-P bidiagonal matrices represented implicitly by */ +/* > angles THETA, PHI. */ +/* > */ +/* >\endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows X11 plus the number of rows in X21. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11. 0 <= P <= f2cmin(M-P,Q,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is COMPLEX array, dimension (LDX11,Q) */ +/* > On entry, the top block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X11) specify reflectors for P1 and */ +/* > the rows of triu(X11,1) specify reflectors for Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. LDX11 >= P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is COMPLEX array, dimension (LDX21,Q) */ +/* > On entry, the bottom block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X21) specify reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X21. LDX21 >= M-P. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (Q) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PHI */ +/* > \verbatim */ +/* > PHI is REAL array, dimension (Q-1) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP1 */ +/* > \verbatim */ +/* > TAUP1 is COMPLEX array, dimension (P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP2 */ +/* > \verbatim */ +/* > TAUP2 is COMPLEX array, dimension (M-P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ1 */ +/* > \verbatim */ +/* > TAUQ1 is COMPLEX array, dimension (Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= M-Q. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ +/* > */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date July 2012 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The upper-bidiagonal blocks B11, B21 are represented implicitly by */ +/* > angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry */ +/* > in each bidiagonal band is a product of a sine or cosine of a THETA */ +/* > with a sine or cosine of a PHI. See [1] or CUNCSD for details. */ +/* > */ +/* > P1, P2, and Q1 are represented as products of elementary reflectors. */ +/* > See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR */ +/* > and CUNGLQ. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cunbdb2_(integer *m, integer *p, integer *q, complex * + x11, integer *ldx11, complex *x21, integer *ldx21, real *theta, real * + phi, complex *taup1, complex *taup2, complex *tauq1, complex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer x11_dim1, x11_offset, x21_dim1, x21_offset, i__1, i__2, i__3, + i__4; + real r__1, r__2; + complex q__1; + + /* Local variables */ + integer lworkmin, lworkopt; + real c__; + integer i__; + real s; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), clarf_(char *, integer *, integer *, complex *, + integer *, complex *, complex *, integer *, complex *); + integer ilarf, llarf, childinfo; + extern /* Subroutine */ int csrot_(integer *, complex *, integer *, + complex *, integer *, real *, real *); + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical lquery; + extern /* Subroutine */ int cunbdb5_(integer *, integer *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, integer *); + integer iorbdb5, lorbdb5; + extern /* Subroutine */ int clarfgp_(integer *, complex *, complex *, + integer *, complex *); + + +/* -- 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..-- */ +/* July 2012 */ + + +/* ==================================================================== */ + + +/* Test input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + --theta; + --phi; + --taup1; + --taup2; + --tauq1; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*p < 0 || *p > *m - *p) { + *info = -2; + } else if (*q < 0 || *q < *p || *m - *q < *p) { + *info = -3; + } else if (*ldx11 < f2cmax(1,*p)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (*ldx21 < f2cmax(i__1,i__2)) { + *info = -7; + } + } + +/* Compute workspace */ + + if (*info == 0) { + ilarf = 2; +/* Computing MAX */ + i__1 = *p - 1, i__2 = *m - *p, i__1 = f2cmax(i__1,i__2), i__2 = *q - 1; + llarf = f2cmax(i__1,i__2); + iorbdb5 = 2; + lorbdb5 = *q - 1; +/* Computing MAX */ + i__1 = ilarf + llarf - 1, i__2 = iorbdb5 + lorbdb5 - 1; + lworkopt = f2cmax(i__1,i__2); + lworkmin = lworkopt; + work[1].r = (real) lworkopt, work[1].i = 0.f; + if (*lwork < lworkmin && ! lquery) { + *info = -14; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNBDB2", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Reduce rows 1, ..., P of X11 and X21 */ + + i__1 = *p; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (i__ > 1) { + i__2 = *q - i__ + 1; + csrot_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11, &x21[i__ - 1 + + i__ * x21_dim1], ldx21, &c__, &s); + } + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11); + i__2 = *q - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + (i__ + 1) * + x11_dim1], ldx11, &tauq1[i__]); + i__2 = i__ + i__ * x11_dim1; + c__ = x11[i__2].r; + i__2 = i__ + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + i__2 = *p - i__; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, &tauq1[ + i__], &x11[i__ + 1 + i__ * x11_dim1], ldx11, &work[ilarf]); + i__2 = *m - *p - i__ + 1; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, &tauq1[ + i__], &x21[i__ + i__ * x21_dim1], ldx21, &work[ilarf]); + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11); + i__2 = *p - i__; +/* Computing 2nd power */ + r__1 = scnrm2_(&i__2, &x11[i__ + 1 + i__ * x11_dim1], &c__1); + i__3 = *m - *p - i__ + 1; +/* Computing 2nd power */ + r__2 = scnrm2_(&i__3, &x21[i__ + i__ * x21_dim1], &c__1); + s = sqrt(r__1 * r__1 + r__2 * r__2); + theta[i__] = atan2(s, c__); + + i__2 = *p - i__; + i__3 = *m - *p - i__ + 1; + i__4 = *q - i__; + cunbdb5_(&i__2, &i__3, &i__4, &x11[i__ + 1 + i__ * x11_dim1], &c__1, & + x21[i__ + i__ * x21_dim1], &c__1, &x11[i__ + 1 + (i__ + 1) * + x11_dim1], ldx11, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, & + work[iorbdb5], &lorbdb5, &childinfo); + i__2 = *p - i__; + cscal_(&i__2, &c_b1, &x11[i__ + 1 + i__ * x11_dim1], &c__1); + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + 1 + i__ * + x21_dim1], &c__1, &taup2[i__]); + if (i__ < *p) { + i__2 = *p - i__; + clarfgp_(&i__2, &x11[i__ + 1 + i__ * x11_dim1], &x11[i__ + 2 + + i__ * x11_dim1], &c__1, &taup1[i__]); + phi[i__] = atan2((real) x11[i__ + 1 + i__ * x11_dim1].r, (real) + x21[i__ + i__ * x21_dim1].r); + c__ = cos(phi[i__]); + s = sin(phi[i__]); + i__2 = i__ + 1 + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + i__2 = *p - i__; + i__3 = *q - i__; + r_cnjg(&q__1, &taup1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + 1 + i__ * x11_dim1], &c__1, & + q__1, &x11[i__ + 1 + (i__ + 1) * x11_dim1], ldx11, &work[ + ilarf]); + } + i__2 = i__ + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *m - *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup2[i__]); + clarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, &q__1, & + x21[i__ + (i__ + 1) * x21_dim1], ldx21, &work[ilarf]); + + } + +/* Reduce the bottom-right portion of X21 to the identity matrix */ + + i__1 = *q; + for (i__ = *p + 1; i__ <= i__1; ++i__) { + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + 1 + i__ * + x21_dim1], &c__1, &taup2[i__]); + i__2 = i__ + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *m - *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup2[i__]); + clarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, &q__1, & + x21[i__ + (i__ + 1) * x21_dim1], ldx21, &work[ilarf]); + } + + return 0; + +/* End of CUNBDB2 */ + +} /* cunbdb2_ */ + diff --git a/lapack-netlib/SRC/cunbdb3.c b/lapack-netlib/SRC/cunbdb3.c new file mode 100644 index 000000000..ec558e39b --- /dev/null +++ b/lapack-netlib/SRC/cunbdb3.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 CUNBDB3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNBDB3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, */ +/* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 */ +/* REAL PHI(*), THETA(*) */ +/* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), */ +/* $ X11(LDX11,*), X21(LDX21,*) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* >\verbatim */ +/* > */ +/* > CUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny */ +/* > matrix X with orthonomal columns: */ +/* > */ +/* > [ B11 ] */ +/* > [ X11 ] [ P1 | ] [ 0 ] */ +/* > [-----] = [---------] [-----] Q1**T . */ +/* > [ X21 ] [ | P2 ] [ B21 ] */ +/* > [ 0 ] */ +/* > */ +/* > X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, */ +/* > Q, or M-Q. Routines CUNBDB1, CUNBDB2, and CUNBDB4 handle cases in */ +/* > which M-P is not the minimum dimension. */ +/* > */ +/* > The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), */ +/* > and (M-Q)-by-(M-Q), respectively. They are represented implicitly by */ +/* > Householder vectors. */ +/* > */ +/* > B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented */ +/* > implicitly by angles THETA, PHI. */ +/* > */ +/* >\endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows X11 plus the number of rows in X21. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11. 0 <= P <= M. M-P <= f2cmin(P,Q,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is COMPLEX array, dimension (LDX11,Q) */ +/* > On entry, the top block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X11) specify reflectors for P1 and */ +/* > the rows of triu(X11,1) specify reflectors for Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. LDX11 >= P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is COMPLEX array, dimension (LDX21,Q) */ +/* > On entry, the bottom block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X21) specify reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X21. LDX21 >= M-P. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (Q) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PHI */ +/* > \verbatim */ +/* > PHI is REAL array, dimension (Q-1) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP1 */ +/* > \verbatim */ +/* > TAUP1 is COMPLEX array, dimension (P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP2 */ +/* > \verbatim */ +/* > TAUP2 is COMPLEX array, dimension (M-P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ1 */ +/* > \verbatim */ +/* > TAUQ1 is COMPLEX array, dimension (Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= M-Q. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ +/* > */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date July 2012 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > \verbatim */ +/* > */ +/* > The upper-bidiagonal blocks B11, B21 are represented implicitly by */ +/* > angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry */ +/* > in each bidiagonal band is a product of a sine or cosine of a THETA */ +/* > with a sine or cosine of a PHI. See [1] or CUNCSD for details. */ +/* > */ +/* > P1, P2, and Q1 are represented as products of elementary reflectors. */ +/* > See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR */ +/* > and CUNGLQ. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cunbdb3_(integer *m, integer *p, integer *q, complex * + x11, integer *ldx11, complex *x21, integer *ldx21, real *theta, real * + phi, complex *taup1, complex *taup2, complex *tauq1, complex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer x11_dim1, x11_offset, x21_dim1, x21_offset, i__1, i__2, i__3, + i__4; + real r__1, r__2; + complex q__1; + + /* Local variables */ + integer lworkmin, lworkopt; + real c__; + integer i__; + real s; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *); + integer ilarf, llarf, childinfo; + extern /* Subroutine */ int csrot_(integer *, complex *, integer *, + complex *, integer *, real *, real *); + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical lquery; + extern /* Subroutine */ int cunbdb5_(integer *, integer *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, integer *); + integer iorbdb5, lorbdb5; + extern /* Subroutine */ int clarfgp_(integer *, complex *, complex *, + integer *, complex *); + + +/* -- 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..-- */ +/* July 2012 */ + + +/* ==================================================================== */ + + +/* Test input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + --theta; + --phi; + --taup1; + --taup2; + --tauq1; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*p << 1 < *m || *p > *m) { + *info = -2; + } else if (*q < *m - *p || *m - *q < *m - *p) { + *info = -3; + } else if (*ldx11 < f2cmax(1,*p)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (*ldx21 < f2cmax(i__1,i__2)) { + *info = -7; + } + } + +/* Compute workspace */ + + if (*info == 0) { + ilarf = 2; +/* Computing MAX */ + i__1 = *p, i__2 = *m - *p - 1, i__1 = f2cmax(i__1,i__2), i__2 = *q - 1; + llarf = f2cmax(i__1,i__2); + iorbdb5 = 2; + lorbdb5 = *q - 1; +/* Computing MAX */ + i__1 = ilarf + llarf - 1, i__2 = iorbdb5 + lorbdb5 - 1; + lworkopt = f2cmax(i__1,i__2); + lworkmin = lworkopt; + work[1].r = (real) lworkopt, work[1].i = 0.f; + if (*lwork < lworkmin && ! lquery) { + *info = -14; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNBDB3", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Reduce rows 1, ..., M-P of X11 and X21 */ + + i__1 = *m - *p; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (i__ > 1) { + i__2 = *q - i__ + 1; + csrot_(&i__2, &x11[i__ - 1 + i__ * x11_dim1], ldx11, &x21[i__ + + i__ * x21_dim1], ldx11, &c__, &s); + } + + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x21[i__ + i__ * x21_dim1], ldx21); + i__2 = *q - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + (i__ + 1) * + x21_dim1], ldx21, &tauq1[i__]); + i__2 = i__ + i__ * x21_dim1; + s = x21[i__2].r; + i__2 = i__ + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *p - i__ + 1; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, &tauq1[ + i__], &x11[i__ + i__ * x11_dim1], ldx11, &work[ilarf]); + i__2 = *m - *p - i__; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, &tauq1[ + i__], &x21[i__ + 1 + i__ * x21_dim1], ldx21, &work[ilarf]); + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x21[i__ + i__ * x21_dim1], ldx21); + i__2 = *p - i__ + 1; +/* Computing 2nd power */ + r__1 = scnrm2_(&i__2, &x11[i__ + i__ * x11_dim1], &c__1); + i__3 = *m - *p - i__; +/* Computing 2nd power */ + r__2 = scnrm2_(&i__3, &x21[i__ + 1 + i__ * x21_dim1], &c__1); + c__ = sqrt(r__1 * r__1 + r__2 * r__2); + theta[i__] = atan2(s, c__); + + i__2 = *p - i__ + 1; + i__3 = *m - *p - i__; + i__4 = *q - i__; + cunbdb5_(&i__2, &i__3, &i__4, &x11[i__ + i__ * x11_dim1], &c__1, &x21[ + i__ + 1 + i__ * x21_dim1], &c__1, &x11[i__ + (i__ + 1) * + x11_dim1], ldx11, &x21[i__ + 1 + (i__ + 1) * x21_dim1], ldx21, + &work[iorbdb5], &lorbdb5, &childinfo); + i__2 = *p - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + 1 + i__ * + x11_dim1], &c__1, &taup1[i__]); + if (i__ < *m - *p) { + i__2 = *m - *p - i__; + clarfgp_(&i__2, &x21[i__ + 1 + i__ * x21_dim1], &x21[i__ + 2 + + i__ * x21_dim1], &c__1, &taup2[i__]); + phi[i__] = atan2((real) x21[i__ + 1 + i__ * x21_dim1].r, (real) + x11[i__ + i__ * x11_dim1].r); + c__ = cos(phi[i__]); + s = sin(phi[i__]); + i__2 = i__ + 1 + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *m - *p - i__; + i__3 = *q - i__; + r_cnjg(&q__1, &taup2[i__]); + clarf_("L", &i__2, &i__3, &x21[i__ + 1 + i__ * x21_dim1], &c__1, & + q__1, &x21[i__ + 1 + (i__ + 1) * x21_dim1], ldx21, &work[ + ilarf]); + } + i__2 = i__ + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + i__2 = *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, &q__1, & + x11[i__ + (i__ + 1) * x11_dim1], ldx11, &work[ilarf]); + + } + +/* Reduce the bottom-right portion of X11 to the identity matrix */ + + i__1 = *q; + for (i__ = *m - *p + 1; i__ <= i__1; ++i__) { + i__2 = *p - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + 1 + i__ * + x11_dim1], &c__1, &taup1[i__]); + i__2 = i__ + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + i__2 = *p - i__ + 1; + i__3 = *q - i__; + r_cnjg(&q__1, &taup1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, &q__1, & + x11[i__ + (i__ + 1) * x11_dim1], ldx11, &work[ilarf]); + } + + return 0; + +/* End of CUNBDB3 */ + +} /* cunbdb3_ */ + diff --git a/lapack-netlib/SRC/cunbdb4.c b/lapack-netlib/SRC/cunbdb4.c new file mode 100644 index 000000000..277fe7d06 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb4.c @@ -0,0 +1,864 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNBDB4 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNBDB4 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, */ +/* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, */ +/* INFO ) */ + +/* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 */ +/* REAL PHI(*), THETA(*) */ +/* COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), */ +/* $ WORK(*), X11(LDX11,*), X21(LDX21,*) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* >\verbatim */ +/* > */ +/* > CUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny */ +/* > matrix X with orthonomal columns: */ +/* > */ +/* > [ B11 ] */ +/* > [ X11 ] [ P1 | ] [ 0 ] */ +/* > [-----] = [---------] [-----] Q1**T . */ +/* > [ X21 ] [ | P2 ] [ B21 ] */ +/* > [ 0 ] */ +/* > */ +/* > X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, */ +/* > M-P, or Q. Routines CUNBDB1, CUNBDB2, and CUNBDB3 handle cases in */ +/* > which M-Q is not the minimum dimension. */ +/* > */ +/* > The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), */ +/* > and (M-Q)-by-(M-Q), respectively. They are represented implicitly by */ +/* > Householder vectors. */ +/* > */ +/* > B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented */ +/* > implicitly by angles THETA, PHI. */ +/* > */ +/* >\endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows X11 plus the number of rows in X21. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= M and */ +/* > M-Q <= f2cmin(P,M-P,Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is COMPLEX array, dimension (LDX11,Q) */ +/* > On entry, the top block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X11) specify reflectors for P1 and */ +/* > the rows of triu(X11,1) specify reflectors for Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. LDX11 >= P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is COMPLEX array, dimension (LDX21,Q) */ +/* > On entry, the bottom block of the matrix X to be reduced. On */ +/* > exit, the columns of tril(X21) specify reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X21. LDX21 >= M-P. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (Q) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PHI */ +/* > \verbatim */ +/* > PHI is REAL array, dimension (Q-1) */ +/* > The entries of the bidiagonal blocks B11, B21 are defined by */ +/* > THETA and PHI. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP1 */ +/* > \verbatim */ +/* > TAUP1 is COMPLEX array, dimension (P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP2 */ +/* > \verbatim */ +/* > TAUP2 is COMPLEX array, dimension (M-P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ1 */ +/* > \verbatim */ +/* > TAUQ1 is COMPLEX array, dimension (Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PHANTOM */ +/* > \verbatim */ +/* > PHANTOM is COMPLEX array, dimension (M) */ +/* > The routine computes an M-by-1 column vector Y that is */ +/* > orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and */ +/* > PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and */ +/* > Y(P+1:M), respectively. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= M-Q. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date July 2012 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > \verbatim */ +/* > */ +/* > The upper-bidiagonal blocks B11, B21 are represented implicitly by */ +/* > angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry */ +/* > in each bidiagonal band is a product of a sine or cosine of a THETA */ +/* > with a sine or cosine of a PHI. See [1] or CUNCSD for details. */ +/* > */ +/* > P1, P2, and Q1 are represented as products of elementary reflectors. */ +/* > See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR */ +/* > and CUNGLQ. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cunbdb4_(integer *m, integer *p, integer *q, complex * + x11, integer *ldx11, complex *x21, integer *ldx21, real *theta, real * + phi, complex *taup1, complex *taup2, complex *tauq1, complex *phantom, + complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer x11_dim1, x11_offset, x21_dim1, x21_offset, i__1, i__2, i__3, + i__4; + real r__1, r__2; + complex q__1; + + /* Local variables */ + integer lworkmin, lworkopt; + real c__; + integer i__, j; + real s; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), clarf_(char *, integer *, integer *, complex *, + integer *, complex *, complex *, integer *, complex *); + integer ilarf, llarf, childinfo; + extern /* Subroutine */ int csrot_(integer *, complex *, integer *, + complex *, integer *, real *, real *); + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical lquery; + extern /* Subroutine */ int cunbdb5_(integer *, integer *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, integer *); + integer iorbdb5, lorbdb5; + extern /* Subroutine */ int clarfgp_(integer *, complex *, complex *, + integer *, complex *); + + +/* -- 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..-- */ +/* July 2012 */ + + +/* ==================================================================== */ + + +/* Test input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + --theta; + --phi; + --taup1; + --taup2; + --tauq1; + --phantom; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*p < *m - *q || *m - *p < *m - *q) { + *info = -2; + } else if (*q < *m - *q || *q > *m) { + *info = -3; + } else if (*ldx11 < f2cmax(1,*p)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (*ldx21 < f2cmax(i__1,i__2)) { + *info = -7; + } + } + +/* Compute workspace */ + + if (*info == 0) { + ilarf = 2; +/* Computing MAX */ + i__1 = *q - 1, i__2 = *p - 1, i__1 = f2cmax(i__1,i__2), i__2 = *m - *p - + 1; + llarf = f2cmax(i__1,i__2); + iorbdb5 = 2; + lorbdb5 = *q; + lworkopt = ilarf + llarf - 1; +/* Computing MAX */ + i__1 = lworkopt, i__2 = iorbdb5 + lorbdb5 - 1; + lworkopt = f2cmax(i__1,i__2); + lworkmin = lworkopt; + work[1].r = (real) lworkopt, work[1].i = 0.f; + if (*lwork < lworkmin && ! lquery) { + *info = -14; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNBDB4", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Reduce columns 1, ..., M-Q of X11 and X21 */ + + i__1 = *m - *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (i__ == 1) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + i__3 = j; + phantom[i__3].r = 0.f, phantom[i__3].i = 0.f; + } + i__2 = *m - *p; + cunbdb5_(p, &i__2, q, &phantom[1], &c__1, &phantom[*p + 1], &c__1, + &x11[x11_offset], ldx11, &x21[x21_offset], ldx21, &work[ + iorbdb5], &lorbdb5, &childinfo); + cscal_(p, &c_b1, &phantom[1], &c__1); + clarfgp_(p, &phantom[1], &phantom[2], &c__1, &taup1[1]); + i__2 = *m - *p; + clarfgp_(&i__2, &phantom[*p + 1], &phantom[*p + 2], &c__1, &taup2[ + 1]); + theta[i__] = atan2((real) phantom[1].r, (real) phantom[*p + 1].r); + c__ = cos(theta[i__]); + s = sin(theta[i__]); + phantom[1].r = 1.f, phantom[1].i = 0.f; + i__2 = *p + 1; + phantom[i__2].r = 1.f, phantom[i__2].i = 0.f; + r_cnjg(&q__1, &taup1[1]); + clarf_("L", p, q, &phantom[1], &c__1, &q__1, &x11[x11_offset], + ldx11, &work[ilarf]); + i__2 = *m - *p; + r_cnjg(&q__1, &taup2[1]); + clarf_("L", &i__2, q, &phantom[*p + 1], &c__1, &q__1, &x21[ + x21_offset], ldx21, &work[ilarf]); + } else { + i__2 = *p - i__ + 1; + i__3 = *m - *p - i__ + 1; + i__4 = *q - i__ + 1; + cunbdb5_(&i__2, &i__3, &i__4, &x11[i__ + (i__ - 1) * x11_dim1], & + c__1, &x21[i__ + (i__ - 1) * x21_dim1], &c__1, &x11[i__ + + i__ * x11_dim1], ldx11, &x21[i__ + i__ * x21_dim1], ldx21, + &work[iorbdb5], &lorbdb5, &childinfo); + i__2 = *p - i__ + 1; + cscal_(&i__2, &c_b1, &x11[i__ + (i__ - 1) * x11_dim1], &c__1); + i__2 = *p - i__ + 1; + clarfgp_(&i__2, &x11[i__ + (i__ - 1) * x11_dim1], &x11[i__ + 1 + ( + i__ - 1) * x11_dim1], &c__1, &taup1[i__]); + i__2 = *m - *p - i__ + 1; + clarfgp_(&i__2, &x21[i__ + (i__ - 1) * x21_dim1], &x21[i__ + 1 + ( + i__ - 1) * x21_dim1], &c__1, &taup2[i__]); + theta[i__] = atan2((real) x11[i__ + (i__ - 1) * x11_dim1].r, ( + real) x21[i__ + (i__ - 1) * x21_dim1].r); + c__ = cos(theta[i__]); + s = sin(theta[i__]); + i__2 = i__ + (i__ - 1) * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + i__2 = i__ + (i__ - 1) * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *p - i__ + 1; + i__3 = *q - i__ + 1; + r_cnjg(&q__1, &taup1[i__]); + clarf_("L", &i__2, &i__3, &x11[i__ + (i__ - 1) * x11_dim1], &c__1, + &q__1, &x11[i__ + i__ * x11_dim1], ldx11, &work[ilarf]); + i__2 = *m - *p - i__ + 1; + i__3 = *q - i__ + 1; + r_cnjg(&q__1, &taup2[i__]); + clarf_("L", &i__2, &i__3, &x21[i__ + (i__ - 1) * x21_dim1], &c__1, + &q__1, &x21[i__ + i__ * x21_dim1], ldx21, &work[ilarf]); + } + + i__2 = *q - i__ + 1; + r__1 = -c__; + csrot_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11, &x21[i__ + i__ * + x21_dim1], ldx21, &s, &r__1); + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x21[i__ + i__ * x21_dim1], ldx21); + i__2 = *q - i__ + 1; + clarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + (i__ + 1) * + x21_dim1], ldx21, &tauq1[i__]); + i__2 = i__ + i__ * x21_dim1; + c__ = x21[i__2].r; + i__2 = i__ + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *p - i__; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, &tauq1[ + i__], &x11[i__ + 1 + i__ * x11_dim1], ldx11, &work[ilarf]); + i__2 = *m - *p - i__; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, &tauq1[ + i__], &x21[i__ + 1 + i__ * x21_dim1], ldx21, &work[ilarf]); + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x21[i__ + i__ * x21_dim1], ldx21); + if (i__ < *m - *q) { + i__2 = *p - i__; +/* Computing 2nd power */ + r__1 = scnrm2_(&i__2, &x11[i__ + 1 + i__ * x11_dim1], &c__1); + i__3 = *m - *p - i__; +/* Computing 2nd power */ + r__2 = scnrm2_(&i__3, &x21[i__ + 1 + i__ * x21_dim1], &c__1); + s = sqrt(r__1 * r__1 + r__2 * r__2); + phi[i__] = atan2(s, c__); + } + + } + +/* Reduce the bottom-right portion of X11 to [ I 0 ] */ + + i__1 = *p; + for (i__ = *m - *q + 1; i__ <= i__1; ++i__) { + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11); + i__2 = *q - i__ + 1; + clarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + (i__ + 1) * + x11_dim1], ldx11, &tauq1[i__]); + i__2 = i__ + i__ * x11_dim1; + x11[i__2].r = 1.f, x11[i__2].i = 0.f; + i__2 = *p - i__; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, &tauq1[ + i__], &x11[i__ + 1 + i__ * x11_dim1], ldx11, &work[ilarf]); + i__2 = *q - *p; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, &tauq1[ + i__], &x21[*m - *q + 1 + i__ * x21_dim1], ldx21, &work[ilarf]); + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x11[i__ + i__ * x11_dim1], ldx11); + } + +/* Reduce the bottom-right portion of X21 to [ 0 I ] */ + + i__1 = *q; + for (i__ = *p + 1; i__ <= i__1; ++i__) { + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x21[*m - *q + i__ - *p + i__ * x21_dim1], ldx21); + i__2 = *q - i__ + 1; + clarfgp_(&i__2, &x21[*m - *q + i__ - *p + i__ * x21_dim1], &x21[*m - * + q + i__ - *p + (i__ + 1) * x21_dim1], ldx21, &tauq1[i__]); + i__2 = *m - *q + i__ - *p + i__ * x21_dim1; + x21[i__2].r = 1.f, x21[i__2].i = 0.f; + i__2 = *q - i__; + i__3 = *q - i__ + 1; + clarf_("R", &i__2, &i__3, &x21[*m - *q + i__ - *p + i__ * x21_dim1], + ldx21, &tauq1[i__], &x21[*m - *q + i__ - *p + 1 + i__ * + x21_dim1], ldx21, &work[ilarf]); + i__2 = *q - i__ + 1; + clacgv_(&i__2, &x21[*m - *q + i__ - *p + i__ * x21_dim1], ldx21); + } + + return 0; + +/* End of CUNBDB4 */ + +} /* cunbdb4_ */ + diff --git a/lapack-netlib/SRC/cunbdb5.c b/lapack-netlib/SRC/cunbdb5.c new file mode 100644 index 000000000..12378fd23 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb5.c @@ -0,0 +1,679 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNBDB5 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNBDB5 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, */ +/* LDQ2, WORK, LWORK, INFO ) */ + +/* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, */ +/* $ N */ +/* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* >\verbatim */ +/* > */ +/* > CUNBDB5 orthogonalizes the column vector */ +/* > X = [ X1 ] */ +/* > [ X2 ] */ +/* > with respect to the columns of */ +/* > Q = [ Q1 ] . */ +/* > [ Q2 ] */ +/* > The columns of Q must be orthonormal. */ +/* > */ +/* > If the projection is zero according to Kahan's "twice is enough" */ +/* > criterion, then some other vector from the orthogonal complement */ +/* > is returned. This vector is chosen in an arbitrary but deterministic */ +/* > way. */ +/* > */ +/* >\endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M1 */ +/* > \verbatim */ +/* > M1 is INTEGER */ +/* > The dimension of X1 and the number of rows in Q1. 0 <= M1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M2 */ +/* > \verbatim */ +/* > M2 is INTEGER */ +/* > The dimension of X2 and the number of rows in Q2. 0 <= M2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns in Q1 and Q2. 0 <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X1 */ +/* > \verbatim */ +/* > X1 is COMPLEX array, dimension (M1) */ +/* > On entry, the top part of the vector to be orthogonalized. */ +/* > On exit, the top part of the projected vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX1 */ +/* > \verbatim */ +/* > INCX1 is INTEGER */ +/* > Increment for entries of X1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X2 */ +/* > \verbatim */ +/* > X2 is COMPLEX array, dimension (M2) */ +/* > On entry, the bottom part of the vector to be */ +/* > orthogonalized. On exit, the bottom part of the projected */ +/* > vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX2 */ +/* > \verbatim */ +/* > INCX2 is INTEGER */ +/* > Increment for entries of X2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q1 */ +/* > \verbatim */ +/* > Q1 is COMPLEX array, dimension (LDQ1, N) */ +/* > The top part of the orthonormal basis matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ1 */ +/* > \verbatim */ +/* > LDQ1 is INTEGER */ +/* > The leading dimension of Q1. LDQ1 >= M1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q2 */ +/* > \verbatim */ +/* > Q2 is COMPLEX array, dimension (LDQ2, N) */ +/* > The bottom part of the orthonormal basis matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ2 */ +/* > \verbatim */ +/* > LDQ2 is INTEGER */ +/* > The leading dimension of Q2. LDQ2 >= M2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= 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 July 2012 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cunbdb5_(integer *m1, integer *m2, integer *n, complex * + x1, integer *incx1, complex *x2, integer *incx2, complex *q1, integer + *ldq1, complex *q2, integer *ldq2, complex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer q1_dim1, q1_offset, q2_dim1, q2_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + integer i__, j, childinfo; + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cunbdb6_( + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* July 2012 */ + + +/* ===================================================================== */ + + +/* Test input arguments */ + + /* Parameter adjustments */ + --x1; + --x2; + q1_dim1 = *ldq1; + q1_offset = 1 + q1_dim1 * 1; + q1 -= q1_offset; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1 * 1; + q2 -= q2_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m1 < 0) { + *info = -1; + } else if (*m2 < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*incx1 < 1) { + *info = -5; + } else if (*incx2 < 1) { + *info = -7; + } else if (*ldq1 < f2cmax(1,*m1)) { + *info = -9; + } else if (*ldq2 < f2cmax(1,*m2)) { + *info = -11; + } else if (*lwork < *n) { + *info = -13; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNBDB5", &i__1, (ftnlen)7); + return 0; + } + +/* Project X onto the orthogonal complement of Q */ + + cunbdb6_(m1, m2, n, &x1[1], incx1, &x2[1], incx2, &q1[q1_offset], ldq1, & + q2[q2_offset], ldq2, &work[1], lwork, &childinfo); + +/* If the projection is nonzero, then return */ + + r__1 = scnrm2_(m1, &x1[1], incx1); + r__2 = scnrm2_(m2, &x2[1], incx2); + if (r__1 != 0.f || r__2 != 0.f) { + return 0; + } + +/* Project each standard basis vector e_1,...,e_M1 in turn, stopping */ +/* when a nonzero projection is found */ + + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m1; + for (j = 1; j <= i__2; ++j) { + i__3 = j; + x1[i__3].r = 0.f, x1[i__3].i = 0.f; + } + i__2 = i__; + x1[i__2].r = 1.f, x1[i__2].i = 0.f; + i__2 = *m2; + for (j = 1; j <= i__2; ++j) { + i__3 = j; + x2[i__3].r = 0.f, x2[i__3].i = 0.f; + } + cunbdb6_(m1, m2, n, &x1[1], incx1, &x2[1], incx2, &q1[q1_offset], + ldq1, &q2[q2_offset], ldq2, &work[1], lwork, &childinfo); + r__1 = scnrm2_(m1, &x1[1], incx1); + r__2 = scnrm2_(m2, &x2[1], incx2); + if (r__1 != 0.f || r__2 != 0.f) { + return 0; + } + } + +/* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn, */ +/* stopping when a nonzero projection is found */ + + i__1 = *m2; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m1; + for (j = 1; j <= i__2; ++j) { + i__3 = j; + x1[i__3].r = 0.f, x1[i__3].i = 0.f; + } + i__2 = *m2; + for (j = 1; j <= i__2; ++j) { + i__3 = j; + x2[i__3].r = 0.f, x2[i__3].i = 0.f; + } + i__2 = i__; + x2[i__2].r = 1.f, x2[i__2].i = 0.f; + cunbdb6_(m1, m2, n, &x1[1], incx1, &x2[1], incx2, &q1[q1_offset], + ldq1, &q2[q2_offset], ldq2, &work[1], lwork, &childinfo); + r__1 = scnrm2_(m1, &x1[1], incx1); + r__2 = scnrm2_(m2, &x2[1], incx2); + if (r__1 != 0.f || r__2 != 0.f) { + return 0; + } + } + + return 0; + +/* End of CUNBDB5 */ + +} /* cunbdb5_ */ + diff --git a/lapack-netlib/SRC/cunbdb6.c b/lapack-netlib/SRC/cunbdb6.c new file mode 100644 index 000000000..0a99f4ce4 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb6.c @@ -0,0 +1,733 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNBDB6 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNBDB6 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, */ +/* LDQ2, WORK, LWORK, INFO ) */ + +/* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, */ +/* $ N */ +/* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* >\verbatim */ +/* > */ +/* > CUNBDB6 orthogonalizes the column vector */ +/* > X = [ X1 ] */ +/* > [ X2 ] */ +/* > with respect to the columns of */ +/* > Q = [ Q1 ] . */ +/* > [ Q2 ] */ +/* > The columns of Q must be orthonormal. */ +/* > */ +/* > If the projection is zero according to Kahan's "twice is enough" */ +/* > criterion, then the zero vector is returned. */ +/* > */ +/* >\endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M1 */ +/* > \verbatim */ +/* > M1 is INTEGER */ +/* > The dimension of X1 and the number of rows in Q1. 0 <= M1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M2 */ +/* > \verbatim */ +/* > M2 is INTEGER */ +/* > The dimension of X2 and the number of rows in Q2. 0 <= M2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns in Q1 and Q2. 0 <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X1 */ +/* > \verbatim */ +/* > X1 is COMPLEX array, dimension (M1) */ +/* > On entry, the top part of the vector to be orthogonalized. */ +/* > On exit, the top part of the projected vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX1 */ +/* > \verbatim */ +/* > INCX1 is INTEGER */ +/* > Increment for entries of X1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X2 */ +/* > \verbatim */ +/* > X2 is COMPLEX array, dimension (M2) */ +/* > On entry, the bottom part of the vector to be */ +/* > orthogonalized. On exit, the bottom part of the projected */ +/* > vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX2 */ +/* > \verbatim */ +/* > INCX2 is INTEGER */ +/* > Increment for entries of X2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q1 */ +/* > \verbatim */ +/* > Q1 is COMPLEX array, dimension (LDQ1, N) */ +/* > The top part of the orthonormal basis matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ1 */ +/* > \verbatim */ +/* > LDQ1 is INTEGER */ +/* > The leading dimension of Q1. LDQ1 >= M1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q2 */ +/* > \verbatim */ +/* > Q2 is COMPLEX array, dimension (LDQ2, N) */ +/* > The bottom part of the orthonormal basis matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ2 */ +/* > \verbatim */ +/* > LDQ2 is INTEGER */ +/* > The leading dimension of Q2. LDQ2 >= M2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= 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 July 2012 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cunbdb6_(integer *m1, integer *m2, integer *n, complex * + x1, integer *incx1, complex *x2, integer *incx2, complex *q1, integer + *ldq1, complex *q2, integer *ldq2, complex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer q1_dim1, q1_offset, q2_dim1, q2_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), xerbla_(char *, integer *, ftnlen), classq_( + integer *, complex *, integer *, real *, real *); + real normsq1, normsq2, scl1, scl2, ssq1, ssq2; + + +/* -- 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..-- */ +/* July 2012 */ + + +/* ===================================================================== */ + + +/* Test input arguments */ + + /* Parameter adjustments */ + --x1; + --x2; + q1_dim1 = *ldq1; + q1_offset = 1 + q1_dim1 * 1; + q1 -= q1_offset; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1 * 1; + q2 -= q2_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m1 < 0) { + *info = -1; + } else if (*m2 < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*incx1 < 1) { + *info = -5; + } else if (*incx2 < 1) { + *info = -7; + } else if (*ldq1 < f2cmax(1,*m1)) { + *info = -9; + } else if (*ldq2 < f2cmax(1,*m2)) { + *info = -11; + } else if (*lwork < *n) { + *info = -13; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNBDB6", &i__1, (ftnlen)7); + return 0; + } + +/* First, project X onto the orthogonal complement of Q's column */ +/* space */ + + scl1 = 0.f; + ssq1 = 1.f; + classq_(m1, &x1[1], incx1, &scl1, &ssq1); + scl2 = 0.f; + ssq2 = 1.f; + classq_(m2, &x2[1], incx2, &scl2, &ssq2); +/* Computing 2nd power */ + r__1 = scl1; +/* Computing 2nd power */ + r__2 = scl2; + normsq1 = r__1 * r__1 * ssq1 + r__2 * r__2 * ssq2; + + if (*m1 == 0) { + 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; + } + } else { + cgemv_("C", m1, n, &c_b2, &q1[q1_offset], ldq1, &x1[1], incx1, &c_b3, + &work[1], &c__1); + } + + cgemv_("C", m2, n, &c_b2, &q2[q2_offset], ldq2, &x2[1], incx2, &c_b2, & + work[1], &c__1); + + cgemv_("N", m1, n, &c_b1, &q1[q1_offset], ldq1, &work[1], &c__1, &c_b2, & + x1[1], incx1); + cgemv_("N", m2, n, &c_b1, &q2[q2_offset], ldq2, &work[1], &c__1, &c_b2, & + x2[1], incx2); + + scl1 = 0.f; + ssq1 = 1.f; + classq_(m1, &x1[1], incx1, &scl1, &ssq1); + scl2 = 0.f; + ssq2 = 1.f; + classq_(m2, &x2[1], incx2, &scl2, &ssq2); +/* Computing 2nd power */ + r__1 = scl1; +/* Computing 2nd power */ + r__2 = scl2; + normsq2 = r__1 * r__1 * ssq1 + r__2 * r__2 * ssq2; + +/* If projection is sufficiently large in norm, then stop. */ +/* If projection is zero, then stop. */ +/* Otherwise, project again. */ + + if (normsq2 >= normsq1 * .01f) { + return 0; + } + + if (normsq2 == 0.f) { + return 0; + } + + normsq1 = normsq2; + + 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 (*m1 == 0) { + 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; + } + } else { + cgemv_("C", m1, n, &c_b2, &q1[q1_offset], ldq1, &x1[1], incx1, &c_b3, + &work[1], &c__1); + } + + cgemv_("C", m2, n, &c_b2, &q2[q2_offset], ldq2, &x2[1], incx2, &c_b2, & + work[1], &c__1); + + cgemv_("N", m1, n, &c_b1, &q1[q1_offset], ldq1, &work[1], &c__1, &c_b2, & + x1[1], incx1); + cgemv_("N", m2, n, &c_b1, &q2[q2_offset], ldq2, &work[1], &c__1, &c_b2, & + x2[1], incx2); + + scl1 = 0.f; + ssq1 = 1.f; + classq_(m1, &x1[1], incx1, &scl1, &ssq1); + scl2 = 0.f; + ssq2 = 1.f; + classq_(m1, &x1[1], incx1, &scl1, &ssq1); +/* Computing 2nd power */ + r__1 = scl1; +/* Computing 2nd power */ + r__2 = scl2; + normsq2 = r__1 * r__1 * ssq1 + r__2 * r__2 * ssq2; + +/* If second projection is sufficiently large in norm, then do */ +/* nothing more. Alternatively, if it shrunk significantly, then */ +/* truncate it to zero. */ + + if (normsq2 < normsq1 * .01f) { + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + x1[i__2].r = 0.f, x1[i__2].i = 0.f; + } + i__1 = *m2; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + x2[i__2].r = 0.f, x2[i__2].i = 0.f; + } + } + + return 0; + +/* End of CUNBDB6 */ + +} /* cunbdb6_ */ + diff --git a/lapack-netlib/SRC/cuncsd.c b/lapack-netlib/SRC/cuncsd.c new file mode 100644 index 000000000..52fd4388a --- /dev/null +++ b/lapack-netlib/SRC/cuncsd.c @@ -0,0 +1,1206 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNCSD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNCSD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, */ +/* SIGNS, M, P, Q, X11, LDX11, X12, */ +/* LDX12, X21, LDX21, X22, LDX22, THETA, */ +/* U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, */ +/* LDV2T, WORK, LWORK, RWORK, LRWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS */ +/* INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, */ +/* $ LDX21, LDX22, LRWORK, LWORK, M, P, Q */ +/* INTEGER IWORK( * ) */ +/* REAL THETA( * ) */ +/* REAL RWORK( * ) */ +/* COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), */ +/* $ V2T( LDV2T, * ), WORK( * ), X11( LDX11, * ), */ +/* $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, */ +/* $ * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNCSD computes the CS decomposition of an M-by-M partitioned */ +/* > unitary matrix X: */ +/* > */ +/* > [ I 0 0 | 0 0 0 ] */ +/* > [ 0 C 0 | 0 -S 0 ] */ +/* > [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H */ +/* > X = [-----------] = [---------] [---------------------] [---------] . */ +/* > [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ] */ +/* > [ 0 S 0 | 0 C 0 ] */ +/* > [ 0 0 I | 0 0 0 ] */ +/* > */ +/* > X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P, */ +/* > (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are */ +/* > R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in */ +/* > which R = MIN(P,M-P,Q,M-Q). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU1 */ +/* > \verbatim */ +/* > JOBU1 is CHARACTER */ +/* > = 'Y': U1 is computed; */ +/* > otherwise: U1 is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBU2 */ +/* > \verbatim */ +/* > JOBU2 is CHARACTER */ +/* > = 'Y': U2 is computed; */ +/* > otherwise: U2 is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV1T */ +/* > \verbatim */ +/* > JOBV1T is CHARACTER */ +/* > = 'Y': V1T is computed; */ +/* > otherwise: V1T is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV2T */ +/* > \verbatim */ +/* > JOBV2T is CHARACTER */ +/* > = 'Y': V2T is computed; */ +/* > otherwise: V2T is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER */ +/* > = 'T': X, U1, U2, V1T, and V2T are stored in row-major */ +/* > order; */ +/* > otherwise: X, U1, U2, V1T, and V2T are stored in column- */ +/* > major order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIGNS */ +/* > \verbatim */ +/* > SIGNS is CHARACTER */ +/* > = 'O': The lower-left block is made nonpositive (the */ +/* > "other" convention); */ +/* > otherwise: The upper-right block is made nonpositive (the */ +/* > "default" convention). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows and columns in X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11 and X12. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is COMPLEX array, dimension (LDX11,Q) */ +/* > On entry, part of the unitary matrix whose CSD is desired. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. LDX11 >= MAX(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X12 */ +/* > \verbatim */ +/* > X12 is COMPLEX array, dimension (LDX12,M-Q) */ +/* > On entry, part of the unitary matrix whose CSD is desired. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX12 */ +/* > \verbatim */ +/* > LDX12 is INTEGER */ +/* > The leading dimension of X12. LDX12 >= MAX(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is COMPLEX array, dimension (LDX21,Q) */ +/* > On entry, part of the unitary matrix whose CSD is desired. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X11. LDX21 >= MAX(1,M-P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X22 */ +/* > \verbatim */ +/* > X22 is COMPLEX array, dimension (LDX22,M-Q) */ +/* > On entry, part of the unitary matrix whose CSD is desired. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX22 */ +/* > \verbatim */ +/* > LDX22 is INTEGER */ +/* > The leading dimension of X11. LDX22 >= MAX(1,M-P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (R), in which R = */ +/* > MIN(P,M-P,Q,M-Q). */ +/* > C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and */ +/* > S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U1 */ +/* > \verbatim */ +/* > U1 is COMPLEX array, dimension (LDU1,P) */ +/* > If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU1 */ +/* > \verbatim */ +/* > LDU1 is INTEGER */ +/* > The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= */ +/* > MAX(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U2 */ +/* > \verbatim */ +/* > U2 is COMPLEX array, dimension (LDU2,M-P) */ +/* > If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary */ +/* > matrix U2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU2 */ +/* > \verbatim */ +/* > LDU2 is INTEGER */ +/* > The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= */ +/* > MAX(1,M-P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V1T */ +/* > \verbatim */ +/* > V1T is COMPLEX array, dimension (LDV1T,Q) */ +/* > If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary */ +/* > matrix V1**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV1T */ +/* > \verbatim */ +/* > LDV1T is INTEGER */ +/* > The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= */ +/* > MAX(1,Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V2T */ +/* > \verbatim */ +/* > V2T is COMPLEX array, dimension (LDV2T,M-Q) */ +/* > If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary */ +/* > matrix V2**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV2T */ +/* > \verbatim */ +/* > LDV2T is INTEGER */ +/* > The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >= */ +/* > MAX(1,M-Q). */ +/* > \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 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 MAX(1,LRWORK) */ +/* > On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */ +/* > If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1), */ +/* > ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), */ +/* > define the matrix in intermediate bidiagonal-block form */ +/* > remaining after nonconvergence. INFO specifies the number */ +/* > of nonzero PHI's. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > The dimension of the array RWORK. */ +/* > */ +/* > If LRWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the RWORK array, returns */ +/* > this value as the first entry of the work array, and no error */ +/* > message related to LRWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: CBBCSD did not converge. See the description of RWORK */ +/* > above for details. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cuncsd_(char *jobu1, char *jobu2, char *jobv1t, char * + jobv2t, char *trans, char *signs, integer *m, integer *p, integer *q, + complex *x11, integer *ldx11, complex *x12, integer *ldx12, complex * + x21, integer *ldx21, complex *x22, integer *ldx22, real *theta, + complex *u1, integer *ldu1, complex *u2, integer *ldu2, complex *v1t, + integer *ldv1t, complex *v2t, integer *ldv2t, complex *work, integer * + lwork, real *rwork, integer *lrwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer u1_dim1, u1_offset, u2_dim1, u2_offset, v1t_dim1, v1t_offset, + v2t_dim1, v2t_offset, x11_dim1, x11_offset, x12_dim1, x12_offset, + x21_dim1, x21_offset, x22_dim1, x22_offset, i__1, i__2, i__3, + i__4, i__5, i__6; + + /* Local variables */ + integer ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, iphi; + logical colmajor; + integer lworkmin; + logical defaultsigns; + integer lworkopt, i__, j; + extern logical lsame_(char *, char *); + integer childinfo, p1, q1, lbbcsdworkmin, itaup1, itaup2, itauq1, itauq2, + lorbdbworkmin, lrworkmin, lbbcsdworkopt; + logical wantu1, wantu2; + extern /* Subroutine */ int cbbcsd_(char *, char *, char *, char *, char * + , integer *, integer *, integer *, real *, real *, complex *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, real *, real *, real *, real *, real *, real *, real *, + real *, real *, integer *, integer *); + integer lrworkopt, ibbcsd, lorbdbworkopt; + extern /* Subroutine */ int cunbdb_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, real *, real *, complex *, + complex *, complex *, complex *, complex *, integer *, integer *); + integer iorbdb, lorglqworkmin, lorgqrworkmin; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen), clapmr_(logical *, integer *, integer *, + complex *, integer *, integer *), clapmt_(logical *, integer *, + integer *, complex *, integer *, integer *); + integer lorglqworkopt; + extern /* Subroutine */ int cunglq_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *); + integer lorgqrworkopt, iorglq; + extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *); + integer iorgqr; + char signst[1], transt[1]; + integer lbbcsdwork; + logical lquery; + integer lorbdbwork, lorglqwork, lorgqrwork; + logical wantv1t, wantv2t, lrquery; + + +/* -- 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 input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x12_dim1 = *ldx12; + x12_offset = 1 + x12_dim1 * 1; + x12 -= x12_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + x22_dim1 = *ldx22; + x22_offset = 1 + x22_dim1 * 1; + x22 -= x22_offset; + --theta; + u1_dim1 = *ldu1; + u1_offset = 1 + u1_dim1 * 1; + u1 -= u1_offset; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1 * 1; + u2 -= u2_offset; + v1t_dim1 = *ldv1t; + v1t_offset = 1 + v1t_dim1 * 1; + v1t -= v1t_offset; + v2t_dim1 = *ldv2t; + v2t_offset = 1 + v2t_dim1 * 1; + v2t -= v2t_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + wantu1 = lsame_(jobu1, "Y"); + wantu2 = lsame_(jobu2, "Y"); + wantv1t = lsame_(jobv1t, "Y"); + wantv2t = lsame_(jobv2t, "Y"); + colmajor = ! lsame_(trans, "T"); + defaultsigns = ! lsame_(signs, "O"); + lquery = *lwork == -1; + lrquery = *lrwork == -1; + if (*m < 0) { + *info = -7; + } else if (*p < 0 || *p > *m) { + *info = -8; + } else if (*q < 0 || *q > *m) { + *info = -9; + } else if (colmajor && *ldx11 < f2cmax(1,*p)) { + *info = -11; + } else if (! colmajor && *ldx11 < f2cmax(1,*q)) { + *info = -11; + } else if (colmajor && *ldx12 < f2cmax(1,*p)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + if (! colmajor && *ldx12 < f2cmax(i__1,i__2)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (colmajor && *ldx21 < f2cmax(i__1,i__2)) { + *info = -15; + } else if (! colmajor && *ldx21 < f2cmax(1,*q)) { + *info = -15; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (colmajor && *ldx22 < f2cmax(i__1,i__2)) { + *info = -17; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + if (! colmajor && *ldx22 < f2cmax(i__1,i__2)) { + *info = -17; + } else if (wantu1 && *ldu1 < *p) { + *info = -20; + } else if (wantu2 && *ldu2 < *m - *p) { + *info = -22; + } else if (wantv1t && *ldv1t < *q) { + *info = -24; + } else if (wantv2t && *ldv2t < *m - *q) { + *info = -26; + } + } + } + } + } + +/* Work with transpose if convenient */ + +/* Computing MIN */ + i__1 = *p, i__2 = *m - *p; +/* Computing MIN */ + i__3 = *q, i__4 = *m - *q; + if (*info == 0 && f2cmin(i__1,i__2) < f2cmin(i__3,i__4)) { + if (colmajor) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + if (defaultsigns) { + *(unsigned char *)signst = 'O'; + } else { + *(unsigned char *)signst = 'D'; + } + cuncsd_(jobv1t, jobv2t, jobu1, jobu2, transt, signst, m, q, p, &x11[ + x11_offset], ldx11, &x21[x21_offset], ldx21, &x12[x12_offset], + ldx12, &x22[x22_offset], ldx22, &theta[1], &v1t[v1t_offset], + ldv1t, &v2t[v2t_offset], ldv2t, &u1[u1_offset], ldu1, &u2[ + u2_offset], ldu2, &work[1], lwork, &rwork[1], lrwork, &iwork[ + 1], info); + return 0; + } + +/* Work with permutation [ 0 I; I 0 ] * X * [ 0 I; I 0 ] if */ +/* convenient */ + + if (*info == 0 && *m - *q < *q) { + if (defaultsigns) { + *(unsigned char *)signst = 'O'; + } else { + *(unsigned char *)signst = 'D'; + } + i__1 = *m - *p; + i__2 = *m - *q; + cuncsd_(jobu2, jobu1, jobv2t, jobv1t, trans, signst, m, &i__1, &i__2, + &x22[x22_offset], ldx22, &x21[x21_offset], ldx21, &x12[ + x12_offset], ldx12, &x11[x11_offset], ldx11, &theta[1], &u2[ + u2_offset], ldu2, &u1[u1_offset], ldu1, &v2t[v2t_offset], + ldv2t, &v1t[v1t_offset], ldv1t, &work[1], lwork, &rwork[1], + lrwork, &iwork[1], info); + return 0; + } + +/* Compute workspace */ + + if (*info == 0) { + +/* Real workspace */ + + iphi = 2; +/* Computing MAX */ + i__1 = 1, i__2 = *q - 1; + ib11d = iphi + f2cmax(i__1,i__2); + ib11e = ib11d + f2cmax(1,*q); +/* Computing MAX */ + i__1 = 1, i__2 = *q - 1; + ib12d = ib11e + f2cmax(i__1,i__2); + ib12e = ib12d + f2cmax(1,*q); +/* Computing MAX */ + i__1 = 1, i__2 = *q - 1; + ib21d = ib12e + f2cmax(i__1,i__2); + ib21e = ib21d + f2cmax(1,*q); +/* Computing MAX */ + i__1 = 1, i__2 = *q - 1; + ib22d = ib21e + f2cmax(i__1,i__2); + ib22e = ib22d + f2cmax(1,*q); +/* Computing MAX */ + i__1 = 1, i__2 = *q - 1; + ibbcsd = ib22e + f2cmax(i__1,i__2); + cbbcsd_(jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, &theta[1], & + theta[1], &u1[u1_offset], ldu1, &u2[u2_offset], ldu2, &v1t[ + v1t_offset], ldv1t, &v2t[v2t_offset], ldv2t, &theta[1], & + theta[1], &theta[1], &theta[1], &theta[1], &theta[1], &theta[ + 1], &theta[1], &rwork[1], &c_n1, &childinfo); + lbbcsdworkopt = (integer) rwork[1]; + lbbcsdworkmin = lbbcsdworkopt; + lrworkopt = ibbcsd + lbbcsdworkopt - 1; + lrworkmin = ibbcsd + lbbcsdworkmin - 1; + rwork[1] = (real) lrworkopt; + +/* Complex workspace */ + + itaup1 = 2; + itaup2 = itaup1 + f2cmax(1,*p); +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + itauq1 = itaup2 + f2cmax(i__1,i__2); + itauq2 = itauq1 + f2cmax(1,*q); +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + iorgqr = itauq2 + f2cmax(i__1,i__2); + i__1 = *m - *q; + i__2 = *m - *q; + i__3 = *m - *q; +/* Computing MAX */ + i__5 = 1, i__6 = *m - *q; + i__4 = f2cmax(i__5,i__6); + cungqr_(&i__1, &i__2, &i__3, &u1[u1_offset], &i__4, &u1[u1_offset], & + work[1], &c_n1, &childinfo); + lorgqrworkopt = (integer) work[1].r; +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + lorgqrworkmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + iorglq = itauq2 + f2cmax(i__1,i__2); + i__1 = *m - *q; + i__2 = *m - *q; + i__3 = *m - *q; +/* Computing MAX */ + i__5 = 1, i__6 = *m - *q; + i__4 = f2cmax(i__5,i__6); + cunglq_(&i__1, &i__2, &i__3, &u1[u1_offset], &i__4, &u1[u1_offset], & + work[1], &c_n1, &childinfo); + lorglqworkopt = (integer) work[1].r; +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + lorglqworkmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + iorbdb = itauq2 + f2cmax(i__1,i__2); + cunbdb_(trans, signs, m, p, q, &x11[x11_offset], ldx11, &x12[ + x12_offset], ldx12, &x21[x21_offset], ldx21, &x22[x22_offset], + ldx22, &theta[1], &theta[1], &u1[u1_offset], &u2[u2_offset], + &v1t[v1t_offset], &v2t[v2t_offset], &work[1], &c_n1, & + childinfo); + lorbdbworkopt = (integer) work[1].r; + lorbdbworkmin = lorbdbworkopt; +/* Computing MAX */ + i__1 = iorgqr + lorgqrworkopt, i__2 = iorglq + lorglqworkopt, i__1 = + f2cmax(i__1,i__2), i__2 = iorbdb + lorbdbworkopt; + lworkopt = f2cmax(i__1,i__2) - 1; +/* Computing MAX */ + i__1 = iorgqr + lorgqrworkmin, i__2 = iorglq + lorglqworkmin, i__1 = + f2cmax(i__1,i__2), i__2 = iorbdb + lorbdbworkmin; + lworkmin = f2cmax(i__1,i__2) - 1; + i__1 = f2cmax(lworkopt,lworkmin); + work[1].r = (real) i__1, work[1].i = 0.f; + + if (*lwork < lworkmin && ! (lquery || lrquery)) { + *info = -22; + } else if (*lrwork < lrworkmin && ! (lquery || lrquery)) { + *info = -24; + } else { + lorgqrwork = *lwork - iorgqr + 1; + lorglqwork = *lwork - iorglq + 1; + lorbdbwork = *lwork - iorbdb + 1; + lbbcsdwork = *lrwork - ibbcsd + 1; + } + } + +/* Abort if any illegal arguments */ + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNCSD", &i__1, (ftnlen)6); + return 0; + } else if (lquery || lrquery) { + return 0; + } + +/* Transform to bidiagonal block form */ + + cunbdb_(trans, signs, m, p, q, &x11[x11_offset], ldx11, &x12[x12_offset], + ldx12, &x21[x21_offset], ldx21, &x22[x22_offset], ldx22, &theta[1] + , &rwork[iphi], &work[itaup1], &work[itaup2], &work[itauq1], & + work[itauq2], &work[iorbdb], &lorbdbwork, &childinfo); + +/* Accumulate Householder reflectors */ + + if (colmajor) { + if (wantu1 && *p > 0) { + clacpy_("L", p, q, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1); + cungqr_(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ + iorgqr], &lorgqrwork, info); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + clacpy_("L", &i__1, q, &x21[x21_offset], ldx21, &u2[u2_offset], + ldu2); + i__1 = *m - *p; + i__2 = *m - *p; + cungqr_(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & + work[iorgqr], &lorgqrwork, info); + } + if (wantv1t && *q > 0) { + i__1 = *q - 1; + i__2 = *q - 1; + clacpy_("U", &i__1, &i__2, &x11[(x11_dim1 << 1) + 1], ldx11, &v1t[ + (v1t_dim1 << 1) + 2], ldv1t); + i__1 = v1t_dim1 + 1; + v1t[i__1].r = 1.f, v1t[i__1].i = 0.f; + i__1 = *q; + for (j = 2; j <= i__1; ++j) { + i__2 = j * v1t_dim1 + 1; + v1t[i__2].r = 0.f, v1t[i__2].i = 0.f; + i__2 = j + v1t_dim1; + v1t[i__2].r = 0.f, v1t[i__2].i = 0.f; + } + i__1 = *q - 1; + i__2 = *q - 1; + i__3 = *q - 1; + cunglq_(&i__1, &i__2, &i__3, &v1t[(v1t_dim1 << 1) + 2], ldv1t, & + work[itauq1], &work[iorglq], &lorglqwork, info); + } + if (wantv2t && *m - *q > 0) { + i__1 = *m - *q; + clacpy_("U", p, &i__1, &x12[x12_offset], ldx12, &v2t[v2t_offset], + ldv2t); + if (*m - *p > *q) { + i__1 = *m - *p - *q; + i__2 = *m - *p - *q; + clacpy_("U", &i__1, &i__2, &x22[*q + 1 + (*p + 1) * x22_dim1], + ldx22, &v2t[*p + 1 + (*p + 1) * v2t_dim1], ldv2t); + } + if (*m > *q) { + i__1 = *m - *q; + i__2 = *m - *q; + i__3 = *m - *q; + cunglq_(&i__1, &i__2, &i__3, &v2t[v2t_offset], ldv2t, &work[ + itauq2], &work[iorglq], &lorglqwork, info); + } + } + } else { + if (wantu1 && *p > 0) { + clacpy_("U", q, p, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1); + cunglq_(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ + iorglq], &lorglqwork, info); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + clacpy_("U", q, &i__1, &x21[x21_offset], ldx21, &u2[u2_offset], + ldu2); + i__1 = *m - *p; + i__2 = *m - *p; + cunglq_(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & + work[iorglq], &lorglqwork, info); + } + if (wantv1t && *q > 0) { + i__1 = *q - 1; + i__2 = *q - 1; + clacpy_("L", &i__1, &i__2, &x11[x11_dim1 + 2], ldx11, &v1t[( + v1t_dim1 << 1) + 2], ldv1t); + i__1 = v1t_dim1 + 1; + v1t[i__1].r = 1.f, v1t[i__1].i = 0.f; + i__1 = *q; + for (j = 2; j <= i__1; ++j) { + i__2 = j * v1t_dim1 + 1; + v1t[i__2].r = 0.f, v1t[i__2].i = 0.f; + i__2 = j + v1t_dim1; + v1t[i__2].r = 0.f, v1t[i__2].i = 0.f; + } + i__1 = *q - 1; + i__2 = *q - 1; + i__3 = *q - 1; + cungqr_(&i__1, &i__2, &i__3, &v1t[(v1t_dim1 << 1) + 2], ldv1t, & + work[itauq1], &work[iorgqr], &lorgqrwork, info); + } + if (wantv2t && *m - *q > 0) { +/* Computing MIN */ + i__1 = *p + 1; + p1 = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *q + 1; + q1 = f2cmin(i__1,*m); + i__1 = *m - *q; + clacpy_("L", &i__1, p, &x12[x12_offset], ldx12, &v2t[v2t_offset], + ldv2t); + if (*m > *p + *q) { + i__1 = *m - *p - *q; + i__2 = *m - *p - *q; + clacpy_("L", &i__1, &i__2, &x22[p1 + q1 * x22_dim1], ldx22, & + v2t[*p + 1 + (*p + 1) * v2t_dim1], ldv2t); + } + i__1 = *m - *q; + i__2 = *m - *q; + i__3 = *m - *q; + cungqr_(&i__1, &i__2, &i__3, &v2t[v2t_offset], ldv2t, &work[ + itauq2], &work[iorgqr], &lorgqrwork, info); + } + } + +/* Compute the CSD of the matrix in bidiagonal-block form */ + + cbbcsd_(jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, &theta[1], &rwork[ + iphi], &u1[u1_offset], ldu1, &u2[u2_offset], ldu2, &v1t[ + v1t_offset], ldv1t, &v2t[v2t_offset], ldv2t, &rwork[ib11d], & + rwork[ib11e], &rwork[ib12d], &rwork[ib12e], &rwork[ib21d], &rwork[ + ib21e], &rwork[ib22d], &rwork[ib22e], &rwork[ibbcsd], &lbbcsdwork, + info); + +/* Permute rows and columns to place identity submatrices in top- */ +/* left corner of (1,1)-block and/or bottom-right corner of (1,2)- */ +/* block and/or bottom-right corner of (2,1)-block and/or top-left */ +/* corner of (2,2)-block */ + + if (*q > 0 && wantu2) { + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = *m - *p - *q + i__; + } + i__1 = *m - *p; + for (i__ = *q + 1; i__ <= i__1; ++i__) { + iwork[i__] = i__ - *q; + } + if (colmajor) { + i__1 = *m - *p; + i__2 = *m - *p; + clapmt_(&c_false, &i__1, &i__2, &u2[u2_offset], ldu2, &iwork[1]); + } else { + i__1 = *m - *p; + i__2 = *m - *p; + clapmr_(&c_false, &i__1, &i__2, &u2[u2_offset], ldu2, &iwork[1]); + } + } + if (*m > 0 && wantv2t) { + i__1 = *p; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = *m - *p - *q + i__; + } + i__1 = *m - *q; + for (i__ = *p + 1; i__ <= i__1; ++i__) { + iwork[i__] = i__ - *p; + } + if (! colmajor) { + i__1 = *m - *q; + i__2 = *m - *q; + clapmt_(&c_false, &i__1, &i__2, &v2t[v2t_offset], ldv2t, &iwork[1] + ); + } else { + i__1 = *m - *q; + i__2 = *m - *q; + clapmr_(&c_false, &i__1, &i__2, &v2t[v2t_offset], ldv2t, &iwork[1] + ); + } + } + + return 0; + +/* End CUNCSD */ + +} /* cuncsd_ */ + diff --git a/lapack-netlib/SRC/cuncsd2by1.c b/lapack-netlib/SRC/cuncsd2by1.c new file mode 100644 index 000000000..e93b39f8e --- /dev/null +++ b/lapack-netlib/SRC/cuncsd2by1.c @@ -0,0 +1,1357 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNCSD2BY1 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNCSD2BY1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, */ +/* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, */ +/* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER JOBU1, JOBU2, JOBV1T */ +/* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, */ +/* $ M, P, Q */ +/* INTEGER LRWORK, LRWORKMIN, LRWORKOPT */ +/* REAL RWORK(*) */ +/* REAL THETA(*) */ +/* COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), */ +/* $ X11(LDX11,*), X21(LDX21,*) */ +/* INTEGER IWORK(*) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* >\verbatim */ +/* > */ +/* > CUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with */ +/* > orthonormal columns that has been partitioned into a 2-by-1 block */ +/* > structure: */ +/* > */ +/* > [ I1 0 0 ] */ +/* > [ 0 C 0 ] */ +/* > [ X11 ] [ U1 | ] [ 0 0 0 ] */ +/* > X = [-----] = [---------] [----------] V1**T . */ +/* > [ X21 ] [ | U2 ] [ 0 0 0 ] */ +/* > [ 0 S 0 ] */ +/* > [ 0 0 I2] */ +/* > */ +/* > X11 is P-by-Q. The unitary matrices U1, U2, and V1 are P-by-P, */ +/* > (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R */ +/* > nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which */ +/* > R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a */ +/* > K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU1 */ +/* > \verbatim */ +/* > JOBU1 is CHARACTER */ +/* > = 'Y': U1 is computed; */ +/* > otherwise: U1 is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBU2 */ +/* > \verbatim */ +/* > JOBU2 is CHARACTER */ +/* > = 'Y': U2 is computed; */ +/* > otherwise: U2 is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV1T */ +/* > \verbatim */ +/* > JOBV1T is CHARACTER */ +/* > = 'Y': V1T is computed; */ +/* > otherwise: V1T is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows in X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is COMPLEX array, dimension (LDX11,Q) */ +/* > On entry, part of the unitary matrix whose CSD is desired. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. LDX11 >= MAX(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is COMPLEX array, dimension (LDX21,Q) */ +/* > On entry, part of the unitary matrix whose CSD is desired. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X21. LDX21 >= MAX(1,M-P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (R), in which R = */ +/* > MIN(P,M-P,Q,M-Q). */ +/* > C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and */ +/* > S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U1 */ +/* > \verbatim */ +/* > U1 is COMPLEX array, dimension (P) */ +/* > If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU1 */ +/* > \verbatim */ +/* > LDU1 is INTEGER */ +/* > The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= */ +/* > MAX(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U2 */ +/* > \verbatim */ +/* > U2 is COMPLEX array, dimension (M-P) */ +/* > If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary */ +/* > matrix U2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU2 */ +/* > \verbatim */ +/* > LDU2 is INTEGER */ +/* > The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= */ +/* > MAX(1,M-P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V1T */ +/* > \verbatim */ +/* > V1T is COMPLEX array, dimension (Q) */ +/* > If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary */ +/* > matrix V1**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV1T */ +/* > \verbatim */ +/* > LDV1T is INTEGER */ +/* > The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= */ +/* > MAX(1,Q). */ +/* > \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 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 (MAX(1,LRWORK)) */ +/* > On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */ +/* > If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1), */ +/* > ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), */ +/* > define the matrix in intermediate bidiagonal-block form */ +/* > remaining after nonconvergence. INFO specifies the number */ +/* > of nonzero PHI's. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > The dimension of the array RWORK. */ +/* > */ +/* > If LRWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the RWORK array, returns */ +/* > this value as the first entry of the work array, and no error */ +/* > message related to LRWORK is issued by XERBLA. */ +/* > \endverbatim */ + +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: CBBCSD did not converge. See the description of WORK */ +/* > above for details. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cuncsd2by1_(char *jobu1, char *jobu2, char *jobv1t, + integer *m, integer *p, integer *q, complex *x11, integer *ldx11, + complex *x21, integer *ldx21, real *theta, complex *u1, integer *ldu1, + complex *u2, integer *ldu2, complex *v1t, integer *ldv1t, complex * + work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer u1_dim1, u1_offset, u2_dim1, u2_offset, v1t_dim1, v1t_offset, + x11_dim1, x11_offset, x21_dim1, x21_offset, i__1, i__2, i__3; + + /* Local variables */ + integer ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e; + complex cdum[1] /* was [1][1] */; + integer iphi, lworkmin, lworkopt, i__, j, r__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + integer childinfo, lorglqmin, lorgqrmin, lorglqopt, lrworkmin, itaup1, + itaup2, itauq1, lorgqropt; + logical wantu1, wantu2; + extern /* Subroutine */ int cbbcsd_(char *, char *, char *, char *, char * + , integer *, integer *, integer *, real *, real *, complex *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, real *, real *, real *, real *, real *, real *, real *, + real *, real *, integer *, integer *); + integer lrworkopt, ibbcsd, lbbcsd, iorbdb, lorbdb; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen), clapmr_(logical *, integer *, integer *, + complex *, integer *, integer *), clapmt_(logical *, integer *, + integer *, complex *, integer *, integer *), cunglq_(integer *, + integer *, integer *, complex *, integer *, complex *, complex *, + integer *, integer *); + integer iorglq; + extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *); + integer lorglq, iorgqr, lorgqr; + extern /* Subroutine */ int cunbdb1_(integer *, integer *, integer *, + complex *, integer *, complex *, integer *, real *, real *, + complex *, complex *, complex *, complex *, integer *, integer *), + cunbdb2_(integer *, integer *, integer *, complex *, integer *, + complex *, integer *, real *, real *, complex *, complex *, + complex *, complex *, integer *, integer *); + logical lquery; + extern /* Subroutine */ int cunbdb3_(integer *, integer *, integer *, + complex *, integer *, complex *, integer *, real *, real *, + complex *, complex *, complex *, complex *, integer *, integer *), + cunbdb4_(integer *, integer *, integer *, complex *, integer *, + complex *, integer *, real *, real *, complex *, complex *, + complex *, complex *, complex *, integer *, integer *); + logical wantv1t; + real dum[1]; + + +/* -- 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 input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + --theta; + u1_dim1 = *ldu1; + u1_offset = 1 + u1_dim1 * 1; + u1 -= u1_offset; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1 * 1; + u2 -= u2_offset; + v1t_dim1 = *ldv1t; + v1t_offset = 1 + v1t_dim1 * 1; + v1t -= v1t_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + wantu1 = lsame_(jobu1, "Y"); + wantu2 = lsame_(jobu2, "Y"); + wantv1t = lsame_(jobv1t, "Y"); + lquery = *lwork == -1; + + if (*m < 0) { + *info = -4; + } else if (*p < 0 || *p > *m) { + *info = -5; + } else if (*q < 0 || *q > *m) { + *info = -6; + } else if (*ldx11 < f2cmax(1,*p)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (*ldx21 < f2cmax(i__1,i__2)) { + *info = -10; + } else if (wantu1 && *ldu1 < f2cmax(1,*p)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (wantu2 && *ldu2 < f2cmax(i__1,i__2)) { + *info = -15; + } else if (wantv1t && *ldv1t < f2cmax(1,*q)) { + *info = -17; + } + } + } + +/* Computing MIN */ + i__1 = *p, i__2 = *m - *p, i__1 = f2cmin(i__1,i__2), i__1 = f2cmin(i__1,*q), + i__2 = *m - *q; + r__ = f2cmin(i__1,i__2); + +/* Compute workspace */ + +/* WORK layout: */ +/* |-----------------------------------------| */ +/* | LWORKOPT (1) | */ +/* |-----------------------------------------| */ +/* | TAUP1 (MAX(1,P)) | */ +/* | TAUP2 (MAX(1,M-P)) | */ +/* | TAUQ1 (MAX(1,Q)) | */ +/* |-----------------------------------------| */ +/* | CUNBDB WORK | CUNGQR WORK | CUNGLQ WORK | */ +/* | | | | */ +/* | | | | */ +/* | | | | */ +/* | | | | */ +/* |-----------------------------------------| */ +/* RWORK layout: */ +/* |------------------| */ +/* | LRWORKOPT (1) | */ +/* |------------------| */ +/* | PHI (MAX(1,R-1)) | */ +/* |------------------| */ +/* | B11D (R) | */ +/* | B11E (R-1) | */ +/* | B12D (R) | */ +/* | B12E (R-1) | */ +/* | B21D (R) | */ +/* | B21E (R-1) | */ +/* | B22D (R) | */ +/* | B22E (R-1) | */ +/* | CBBCSD RWORK | */ +/* |------------------| */ + + if (*info == 0) { + iphi = 2; +/* Computing MAX */ + i__1 = 1, i__2 = r__ - 1; + ib11d = iphi + f2cmax(i__1,i__2); + ib11e = ib11d + f2cmax(1,r__); +/* Computing MAX */ + i__1 = 1, i__2 = r__ - 1; + ib12d = ib11e + f2cmax(i__1,i__2); + ib12e = ib12d + f2cmax(1,r__); +/* Computing MAX */ + i__1 = 1, i__2 = r__ - 1; + ib21d = ib12e + f2cmax(i__1,i__2); + ib21e = ib21d + f2cmax(1,r__); +/* Computing MAX */ + i__1 = 1, i__2 = r__ - 1; + ib22d = ib21e + f2cmax(i__1,i__2); + ib22e = ib22d + f2cmax(1,r__); +/* Computing MAX */ + i__1 = 1, i__2 = r__ - 1; + ibbcsd = ib22e + f2cmax(i__1,i__2); + itaup1 = 2; + itaup2 = itaup1 + f2cmax(1,*p); +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + itauq1 = itaup2 + f2cmax(i__1,i__2); + iorbdb = itauq1 + f2cmax(1,*q); + iorgqr = itauq1 + f2cmax(1,*q); + iorglq = itauq1 + f2cmax(1,*q); + lorgqrmin = 1; + lorgqropt = 1; + lorglqmin = 1; + lorglqopt = 1; + if (r__ == *q) { + cunbdb1_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], + ldx21, &theta[1], dum, cdum, cdum, cdum, &work[1], &c_n1, + &childinfo); + lorbdb = (integer) work[1].r; + if (wantu1 && *p > 0) { + cungqr_(p, p, q, &u1[u1_offset], ldu1, cdum, &work[1], &c_n1, + &childinfo); + lorgqrmin = f2cmax(lorgqrmin,*p); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + i__2 = *m - *p; + cungqr_(&i__1, &i__2, q, &u2[u2_offset], ldu2, cdum, &work[1], + &c_n1, &childinfo); +/* Computing MAX */ + i__1 = lorgqrmin, i__2 = *m - *p; + lorgqrmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantv1t && *q > 0) { + i__1 = *q - 1; + i__2 = *q - 1; + i__3 = *q - 1; + cunglq_(&i__1, &i__2, &i__3, &v1t[v1t_offset], ldv1t, cdum, & + work[1], &c_n1, &childinfo); +/* Computing MAX */ + i__1 = lorglqmin, i__2 = *q - 1; + lorglqmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = lorglqopt, i__2 = (integer) work[1].r; + lorglqopt = f2cmax(i__1,i__2); + } + cbbcsd_(jobu1, jobu2, jobv1t, "N", "N", m, p, q, &theta[1], dum, & + u1[u1_offset], ldu1, &u2[u2_offset], ldu2, &v1t[ + v1t_offset], ldv1t, cdum, &c__1, dum, dum, dum, dum, dum, + dum, dum, dum, &rwork[1], &c_n1, &childinfo); + lbbcsd = (integer) rwork[1]; + } else if (r__ == *p) { + cunbdb2_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], + ldx21, &theta[1], dum, cdum, cdum, cdum, &work[1], &c_n1, + &childinfo); + lorbdb = (integer) work[1].r; + if (wantu1 && *p > 0) { + i__1 = *p - 1; + i__2 = *p - 1; + i__3 = *p - 1; + cungqr_(&i__1, &i__2, &i__3, &u1[(u1_dim1 << 1) + 2], ldu1, + cdum, &work[1], &c_n1, &childinfo); +/* Computing MAX */ + i__1 = lorgqrmin, i__2 = *p - 1; + lorgqrmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + i__2 = *m - *p; + cungqr_(&i__1, &i__2, q, &u2[u2_offset], ldu2, cdum, &work[1], + &c_n1, &childinfo); +/* Computing MAX */ + i__1 = lorgqrmin, i__2 = *m - *p; + lorgqrmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantv1t && *q > 0) { + cunglq_(q, q, &r__, &v1t[v1t_offset], ldv1t, cdum, &work[1], & + c_n1, &childinfo); + lorglqmin = f2cmax(lorglqmin,*q); +/* Computing MAX */ + i__1 = lorglqopt, i__2 = (integer) work[1].r; + lorglqopt = f2cmax(i__1,i__2); + } + cbbcsd_(jobv1t, "N", jobu1, jobu2, "T", m, q, p, &theta[1], dum, & + v1t[v1t_offset], ldv1t, cdum, &c__1, &u1[u1_offset], ldu1, + &u2[u2_offset], ldu2, dum, dum, dum, dum, dum, dum, dum, + dum, &rwork[1], &c_n1, &childinfo); + lbbcsd = (integer) rwork[1]; + } else if (r__ == *m - *p) { + cunbdb3_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], + ldx21, &theta[1], dum, cdum, cdum, cdum, &work[1], &c_n1, + &childinfo); + lorbdb = (integer) work[1].r; + if (wantu1 && *p > 0) { + cungqr_(p, p, q, &u1[u1_offset], ldu1, cdum, &work[1], &c_n1, + &childinfo); + lorgqrmin = f2cmax(lorgqrmin,*p); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p - 1; + i__2 = *m - *p - 1; + i__3 = *m - *p - 1; + cungqr_(&i__1, &i__2, &i__3, &u2[(u2_dim1 << 1) + 2], ldu2, + cdum, &work[1], &c_n1, &childinfo); +/* Computing MAX */ + i__1 = lorgqrmin, i__2 = *m - *p - 1; + lorgqrmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantv1t && *q > 0) { + cunglq_(q, q, &r__, &v1t[v1t_offset], ldv1t, cdum, &work[1], & + c_n1, &childinfo); + lorglqmin = f2cmax(lorglqmin,*q); +/* Computing MAX */ + i__1 = lorglqopt, i__2 = (integer) work[1].r; + lorglqopt = f2cmax(i__1,i__2); + } + i__1 = *m - *q; + i__2 = *m - *p; + cbbcsd_("N", jobv1t, jobu2, jobu1, "T", m, &i__1, &i__2, &theta[1] + , dum, cdum, &c__1, &v1t[v1t_offset], ldv1t, &u2[ + u2_offset], ldu2, &u1[u1_offset], ldu1, dum, dum, dum, + dum, dum, dum, dum, dum, &rwork[1], &c_n1, &childinfo); + lbbcsd = (integer) rwork[1]; + } else { + cunbdb4_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], + ldx21, &theta[1], dum, cdum, cdum, cdum, cdum, &work[1], & + c_n1, &childinfo); + lorbdb = *m + (integer) work[1].r; + if (wantu1 && *p > 0) { + i__1 = *m - *q; + cungqr_(p, p, &i__1, &u1[u1_offset], ldu1, cdum, &work[1], & + c_n1, &childinfo); + lorgqrmin = f2cmax(lorgqrmin,*p); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + i__2 = *m - *p; + i__3 = *m - *q; + cungqr_(&i__1, &i__2, &i__3, &u2[u2_offset], ldu2, cdum, & + work[1], &c_n1, &childinfo); +/* Computing MAX */ + i__1 = lorgqrmin, i__2 = *m - *p; + lorgqrmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = lorgqropt, i__2 = (integer) work[1].r; + lorgqropt = f2cmax(i__1,i__2); + } + if (wantv1t && *q > 0) { + cunglq_(q, q, q, &v1t[v1t_offset], ldv1t, cdum, &work[1], & + c_n1, &childinfo); + lorglqmin = f2cmax(lorglqmin,*q); +/* Computing MAX */ + i__1 = lorglqopt, i__2 = (integer) work[1].r; + lorglqopt = f2cmax(i__1,i__2); + } + i__1 = *m - *p; + i__2 = *m - *q; + cbbcsd_(jobu2, jobu1, "N", jobv1t, "N", m, &i__1, &i__2, &theta[1] + , dum, &u2[u2_offset], ldu2, &u1[u1_offset], ldu1, cdum, & + c__1, &v1t[v1t_offset], ldv1t, dum, dum, dum, dum, dum, + dum, dum, dum, &rwork[1], &c_n1, &childinfo); + lbbcsd = (integer) rwork[1]; + } + lrworkmin = ibbcsd + lbbcsd - 1; + lrworkopt = lrworkmin; + rwork[1] = (real) lrworkopt; +/* Computing MAX */ + i__1 = iorbdb + lorbdb - 1, i__2 = iorgqr + lorgqrmin - 1, i__1 = f2cmax( + i__1,i__2), i__2 = iorglq + lorglqmin - 1; + lworkmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = iorbdb + lorbdb - 1, i__2 = iorgqr + lorgqropt - 1, i__1 = f2cmax( + i__1,i__2), i__2 = iorglq + lorglqopt - 1; + lworkopt = f2cmax(i__1,i__2); + work[1].r = (real) lworkopt, work[1].i = 0.f; + if (*lwork < lworkmin && ! lquery) { + *info = -19; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNCSD2BY1", &i__1, (ftnlen)10); + return 0; + } else if (lquery) { + return 0; + } + lorgqr = *lwork - iorgqr + 1; + lorglq = *lwork - iorglq + 1; + +/* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q, */ +/* in which R = MIN(P,M-P,Q,M-Q) */ + + if (r__ == *q) { + +/* Case 1: R = Q */ + +/* Simultaneously bidiagonalize X11 and X21 */ + + cunbdb1_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], ldx21, & + theta[1], &rwork[iphi], &work[itaup1], &work[itaup2], &work[ + itauq1], &work[iorbdb], &lorbdb, &childinfo); + +/* Accumulate Householder reflectors */ + + if (wantu1 && *p > 0) { + clacpy_("L", p, q, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1); + cungqr_(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ + iorgqr], &lorgqr, &childinfo); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + clacpy_("L", &i__1, q, &x21[x21_offset], ldx21, &u2[u2_offset], + ldu2); + i__1 = *m - *p; + i__2 = *m - *p; + cungqr_(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & + work[iorgqr], &lorgqr, &childinfo); + } + if (wantv1t && *q > 0) { + i__1 = v1t_dim1 + 1; + v1t[i__1].r = 1.f, v1t[i__1].i = 0.f; + i__1 = *q; + for (j = 2; j <= i__1; ++j) { + i__2 = j * v1t_dim1 + 1; + v1t[i__2].r = 0.f, v1t[i__2].i = 0.f; + i__2 = j + v1t_dim1; + v1t[i__2].r = 0.f, v1t[i__2].i = 0.f; + } + i__1 = *q - 1; + i__2 = *q - 1; + clacpy_("U", &i__1, &i__2, &x21[(x21_dim1 << 1) + 1], ldx21, &v1t[ + (v1t_dim1 << 1) + 2], ldv1t); + i__1 = *q - 1; + i__2 = *q - 1; + i__3 = *q - 1; + cunglq_(&i__1, &i__2, &i__3, &v1t[(v1t_dim1 << 1) + 2], ldv1t, & + work[itauq1], &work[iorglq], &lorglq, &childinfo); + } + +/* Simultaneously diagonalize X11 and X21. */ + + cbbcsd_(jobu1, jobu2, jobv1t, "N", "N", m, p, q, &theta[1], &rwork[ + iphi], &u1[u1_offset], ldu1, &u2[u2_offset], ldu2, &v1t[ + v1t_offset], ldv1t, cdum, &c__1, &rwork[ib11d], &rwork[ib11e], + &rwork[ib12d], &rwork[ib12e], &rwork[ib21d], &rwork[ib21e], & + rwork[ib22d], &rwork[ib22e], &rwork[ibbcsd], &lbbcsd, & + childinfo); + +/* Permute rows and columns to place zero submatrices in */ +/* preferred positions */ + + if (*q > 0 && wantu2) { + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = *m - *p - *q + i__; + } + i__1 = *m - *p; + for (i__ = *q + 1; i__ <= i__1; ++i__) { + iwork[i__] = i__ - *q; + } + i__1 = *m - *p; + i__2 = *m - *p; + clapmt_(&c_false, &i__1, &i__2, &u2[u2_offset], ldu2, &iwork[1]); + } + } else if (r__ == *p) { + +/* Case 2: R = P */ + +/* Simultaneously bidiagonalize X11 and X21 */ + + cunbdb2_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], ldx21, & + theta[1], &rwork[iphi], &work[itaup1], &work[itaup2], &work[ + itauq1], &work[iorbdb], &lorbdb, &childinfo); + +/* Accumulate Householder reflectors */ + + if (wantu1 && *p > 0) { + i__1 = u1_dim1 + 1; + u1[i__1].r = 1.f, u1[i__1].i = 0.f; + i__1 = *p; + for (j = 2; j <= i__1; ++j) { + i__2 = j * u1_dim1 + 1; + u1[i__2].r = 0.f, u1[i__2].i = 0.f; + i__2 = j + u1_dim1; + u1[i__2].r = 0.f, u1[i__2].i = 0.f; + } + i__1 = *p - 1; + i__2 = *p - 1; + clacpy_("L", &i__1, &i__2, &x11[x11_dim1 + 2], ldx11, &u1[( + u1_dim1 << 1) + 2], ldu1); + i__1 = *p - 1; + i__2 = *p - 1; + i__3 = *p - 1; + cungqr_(&i__1, &i__2, &i__3, &u1[(u1_dim1 << 1) + 2], ldu1, &work[ + itaup1], &work[iorgqr], &lorgqr, &childinfo); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + clacpy_("L", &i__1, q, &x21[x21_offset], ldx21, &u2[u2_offset], + ldu2); + i__1 = *m - *p; + i__2 = *m - *p; + cungqr_(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & + work[iorgqr], &lorgqr, &childinfo); + } + if (wantv1t && *q > 0) { + clacpy_("U", p, q, &x11[x11_offset], ldx11, &v1t[v1t_offset], + ldv1t); + cunglq_(q, q, &r__, &v1t[v1t_offset], ldv1t, &work[itauq1], &work[ + iorglq], &lorglq, &childinfo); + } + +/* Simultaneously diagonalize X11 and X21. */ + + cbbcsd_(jobv1t, "N", jobu1, jobu2, "T", m, q, p, &theta[1], &rwork[ + iphi], &v1t[v1t_offset], ldv1t, cdum, &c__1, &u1[u1_offset], + ldu1, &u2[u2_offset], ldu2, &rwork[ib11d], &rwork[ib11e], & + rwork[ib12d], &rwork[ib12e], &rwork[ib21d], &rwork[ib21e], & + rwork[ib22d], &rwork[ib22e], &rwork[ibbcsd], &lbbcsd, & + childinfo); + +/* Permute rows and columns to place identity submatrices in */ +/* preferred positions */ + + if (*q > 0 && wantu2) { + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = *m - *p - *q + i__; + } + i__1 = *m - *p; + for (i__ = *q + 1; i__ <= i__1; ++i__) { + iwork[i__] = i__ - *q; + } + i__1 = *m - *p; + i__2 = *m - *p; + clapmt_(&c_false, &i__1, &i__2, &u2[u2_offset], ldu2, &iwork[1]); + } + } else if (r__ == *m - *p) { + +/* Case 3: R = M-P */ + +/* Simultaneously bidiagonalize X11 and X21 */ + + cunbdb3_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], ldx21, & + theta[1], &rwork[iphi], &work[itaup1], &work[itaup2], &work[ + itauq1], &work[iorbdb], &lorbdb, &childinfo); + +/* Accumulate Householder reflectors */ + + if (wantu1 && *p > 0) { + clacpy_("L", p, q, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1); + cungqr_(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ + iorgqr], &lorgqr, &childinfo); + } + if (wantu2 && *m - *p > 0) { + i__1 = u2_dim1 + 1; + u2[i__1].r = 1.f, u2[i__1].i = 0.f; + i__1 = *m - *p; + for (j = 2; j <= i__1; ++j) { + i__2 = j * u2_dim1 + 1; + u2[i__2].r = 0.f, u2[i__2].i = 0.f; + i__2 = j + u2_dim1; + u2[i__2].r = 0.f, u2[i__2].i = 0.f; + } + i__1 = *m - *p - 1; + i__2 = *m - *p - 1; + clacpy_("L", &i__1, &i__2, &x21[x21_dim1 + 2], ldx21, &u2[( + u2_dim1 << 1) + 2], ldu2); + i__1 = *m - *p - 1; + i__2 = *m - *p - 1; + i__3 = *m - *p - 1; + cungqr_(&i__1, &i__2, &i__3, &u2[(u2_dim1 << 1) + 2], ldu2, &work[ + itaup2], &work[iorgqr], &lorgqr, &childinfo); + } + if (wantv1t && *q > 0) { + i__1 = *m - *p; + clacpy_("U", &i__1, q, &x21[x21_offset], ldx21, &v1t[v1t_offset], + ldv1t); + cunglq_(q, q, &r__, &v1t[v1t_offset], ldv1t, &work[itauq1], &work[ + iorglq], &lorglq, &childinfo); + } + +/* Simultaneously diagonalize X11 and X21. */ + + i__1 = *m - *q; + i__2 = *m - *p; + cbbcsd_("N", jobv1t, jobu2, jobu1, "T", m, &i__1, &i__2, &theta[1], & + rwork[iphi], cdum, &c__1, &v1t[v1t_offset], ldv1t, &u2[ + u2_offset], ldu2, &u1[u1_offset], ldu1, &rwork[ib11d], &rwork[ + ib11e], &rwork[ib12d], &rwork[ib12e], &rwork[ib21d], &rwork[ + ib21e], &rwork[ib22d], &rwork[ib22e], &rwork[ibbcsd], &lbbcsd, + &childinfo); + +/* Permute rows and columns to place identity submatrices in */ +/* preferred positions */ + + if (*q > r__) { + i__1 = r__; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = *q - r__ + i__; + } + i__1 = *q; + for (i__ = r__ + 1; i__ <= i__1; ++i__) { + iwork[i__] = i__ - r__; + } + if (wantu1) { + clapmt_(&c_false, p, q, &u1[u1_offset], ldu1, &iwork[1]); + } + if (wantv1t) { + clapmr_(&c_false, q, q, &v1t[v1t_offset], ldv1t, &iwork[1]); + } + } + } else { + +/* Case 4: R = M-Q */ + +/* Simultaneously bidiagonalize X11 and X21 */ + + i__1 = lorbdb - *m; + cunbdb4_(m, p, q, &x11[x11_offset], ldx11, &x21[x21_offset], ldx21, & + theta[1], &rwork[iphi], &work[itaup1], &work[itaup2], &work[ + itauq1], &work[iorbdb], &work[iorbdb + *m], &i__1, &childinfo) + ; + +/* Accumulate Householder reflectors */ + + if (wantu1 && *p > 0) { + ccopy_(p, &work[iorbdb], &c__1, &u1[u1_offset], &c__1); + i__1 = *p; + for (j = 2; j <= i__1; ++j) { + i__2 = j * u1_dim1 + 1; + u1[i__2].r = 0.f, u1[i__2].i = 0.f; + } + i__1 = *p - 1; + i__2 = *m - *q - 1; + clacpy_("L", &i__1, &i__2, &x11[x11_dim1 + 2], ldx11, &u1[( + u1_dim1 << 1) + 2], ldu1); + i__1 = *m - *q; + cungqr_(p, p, &i__1, &u1[u1_offset], ldu1, &work[itaup1], &work[ + iorgqr], &lorgqr, &childinfo); + } + if (wantu2 && *m - *p > 0) { + i__1 = *m - *p; + ccopy_(&i__1, &work[iorbdb + *p], &c__1, &u2[u2_offset], &c__1); + i__1 = *m - *p; + for (j = 2; j <= i__1; ++j) { + i__2 = j * u2_dim1 + 1; + u2[i__2].r = 0.f, u2[i__2].i = 0.f; + } + i__1 = *m - *p - 1; + i__2 = *m - *q - 1; + clacpy_("L", &i__1, &i__2, &x21[x21_dim1 + 2], ldx21, &u2[( + u2_dim1 << 1) + 2], ldu2); + i__1 = *m - *p; + i__2 = *m - *p; + i__3 = *m - *q; + cungqr_(&i__1, &i__2, &i__3, &u2[u2_offset], ldu2, &work[itaup2], + &work[iorgqr], &lorgqr, &childinfo); + } + if (wantv1t && *q > 0) { + i__1 = *m - *q; + clacpy_("U", &i__1, q, &x21[x21_offset], ldx21, &v1t[v1t_offset], + ldv1t); + i__1 = *p - (*m - *q); + i__2 = *q - (*m - *q); + clacpy_("U", &i__1, &i__2, &x11[*m - *q + 1 + (*m - *q + 1) * + x11_dim1], ldx11, &v1t[*m - *q + 1 + (*m - *q + 1) * + v1t_dim1], ldv1t); + i__1 = -(*p) + *q; + i__2 = *q - *p; + clacpy_("U", &i__1, &i__2, &x21[*m - *q + 1 + (*p + 1) * x21_dim1] + , ldx21, &v1t[*p + 1 + (*p + 1) * v1t_dim1], ldv1t); + cunglq_(q, q, q, &v1t[v1t_offset], ldv1t, &work[itauq1], &work[ + iorglq], &lorglq, &childinfo); + } + +/* Simultaneously diagonalize X11 and X21. */ + + i__1 = *m - *p; + i__2 = *m - *q; + cbbcsd_(jobu2, jobu1, "N", jobv1t, "N", m, &i__1, &i__2, &theta[1], & + rwork[iphi], &u2[u2_offset], ldu2, &u1[u1_offset], ldu1, cdum, + &c__1, &v1t[v1t_offset], ldv1t, &rwork[ib11d], &rwork[ib11e], + &rwork[ib12d], &rwork[ib12e], &rwork[ib21d], &rwork[ib21e], & + rwork[ib22d], &rwork[ib22e], &rwork[ibbcsd], &lbbcsd, & + childinfo); + +/* Permute rows and columns to place identity submatrices in */ +/* preferred positions */ + + if (*p > r__) { + i__1 = r__; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = *p - r__ + i__; + } + i__1 = *p; + for (i__ = r__ + 1; i__ <= i__1; ++i__) { + iwork[i__] = i__ - r__; + } + if (wantu1) { + clapmt_(&c_false, p, p, &u1[u1_offset], ldu1, &iwork[1]); + } + if (wantv1t) { + clapmr_(&c_false, p, q, &v1t[v1t_offset], ldv1t, &iwork[1]); + } + } + } + + return 0; + +/* End of CUNCSD2BY1 */ + +} /* cuncsd2by1_ */ + diff --git a/lapack-netlib/SRC/cung2l.c b/lapack-netlib/SRC/cung2l.c new file mode 100644 index 000000000..8ff32d790 --- /dev/null +++ b/lapack-netlib/SRC/cung2l.c @@ -0,0 +1,615 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeq +lf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNG2L + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNG2L generates an m by n complex matrix Q with orthonormal columns, */ +/* > which is defined as the last n columns of a product of k elementary */ +/* > reflectors of order m */ +/* > */ +/* > Q = H(k) . . . H(2) H(1) */ +/* > */ +/* > as returned by CGEQLF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the (n-k+i)-th column must contain the vector which */ +/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by CGEQLF in the last k columns of its array */ +/* > argument A. */ +/* > On exit, the m-by-n matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQLF. */ +/* > \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 has 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 cung2l_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + integer i__, j, l; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), clarf_(char *, integer *, integer *, complex *, + integer *, complex *, complex *, integer *, complex *); + integer ii; + 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 arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNG2L", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + +/* Initialise columns 1:n-k to columns of the unit matrix */ + + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } + i__2 = *m - *n + j + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; +/* L20: */ + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + ii = *n - *k + i__; + +/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */ + + i__2 = *m - *n + ii + ii * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + i__2 = *m - *n + ii; + i__3 = ii - 1; + clarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & + a[a_offset], lda, &work[1]); + i__2 = *m - *n + ii - 1; + i__3 = i__; + q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; + cscal_(&i__2, &q__1, &a[ii * a_dim1 + 1], &c__1); + i__2 = *m - *n + ii + ii * a_dim1; + i__3 = i__; + q__1.r = 1.f - tau[i__3].r, q__1.i = 0.f - tau[i__3].i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + +/* Set A(m-k+i+1:m,n-k+i) to zero */ + + i__2 = *m; + for (l = *m - *n + ii + 1; l <= i__2; ++l) { + i__3 = l + ii * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of CUNG2L */ + +} /* cung2l_ */ + diff --git a/lapack-netlib/SRC/cung2r.c b/lapack-netlib/SRC/cung2r.c new file mode 100644 index 000000000..f57296c6d --- /dev/null +++ b/lapack-netlib/SRC/cung2r.c @@ -0,0 +1,615 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNG2R */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNG2R + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNG2R generates an m by n complex matrix Q with orthonormal columns, */ +/* > which is defined as the first n columns of a product of k elementary */ +/* > reflectors of order m */ +/* > */ +/* > Q = H(1) H(2) . . . H(k) */ +/* > */ +/* > as returned by CGEQRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the i-th column must contain the vector which */ +/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by CGEQRF in the first k columns of its array */ +/* > argument A. */ +/* > On exit, the m by n matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQRF. */ +/* > \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 has 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 cung2r_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + integer i__, j, l; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), clarf_(char *, integer *, integer *, complex *, + integer *, complex *, complex *, integer *, complex *), + 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 arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNG2R", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + +/* Initialise columns k+1:n to columns of the unit matrix */ + + i__1 = *n; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } + i__2 = j + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; +/* L20: */ + } + + for (i__ = *k; i__ >= 1; --i__) { + +/* Apply H(i) to A(i:m,i:n) from the left */ + + if (i__ < *n) { + i__1 = i__ + i__ * a_dim1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + i__1 = *m - i__ + 1; + i__2 = *n - i__; + clarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + } + if (i__ < *m) { + i__1 = *m - i__; + i__2 = i__; + q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i; + cscal_(&i__1, &q__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + } + i__1 = i__ + i__ * a_dim1; + i__2 = i__; + q__1.r = 1.f - tau[i__2].r, q__1.i = 0.f - tau[i__2].i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Set A(1:i-1,i) to zero */ + + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + i__2 = l + i__ * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of CUNG2R */ + +} /* cung2r_ */ + diff --git a/lapack-netlib/SRC/cungbr.c b/lapack-netlib/SRC/cungbr.c new file mode 100644 index 000000000..5d54c0c91 --- /dev/null +++ b/lapack-netlib/SRC/cungbr.c @@ -0,0 +1,767 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGBR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGBR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* CHARACTER VECT */ +/* INTEGER INFO, K, LDA, LWORK, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGBR generates one of the complex unitary matrices Q or P**H */ +/* > determined by CGEBRD when reducing a complex matrix A to bidiagonal */ +/* > form: A = Q * B * P**H. Q and P**H are defined as products of */ +/* > elementary reflectors H(i) or G(i) respectively. */ +/* > */ +/* > If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */ +/* > is of order M: */ +/* > if m >= k, Q = H(1) H(2) . . . H(k) and CUNGBR returns the first n */ +/* > columns of Q, where m >= n >= k; */ +/* > if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR returns Q as an */ +/* > M-by-M matrix. */ +/* > */ +/* > If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H */ +/* > is of order N: */ +/* > if k < n, P**H = G(k) . . . G(2) G(1) and CUNGBR returns the first m */ +/* > rows of P**H, where n >= m >= k; */ +/* > if k >= n, P**H = G(n-1) . . . G(2) G(1) and CUNGBR returns P**H as */ +/* > an N-by-N matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > Specifies whether the matrix Q or the matrix P**H is */ +/* > required, as defined in the transformation applied by CGEBRD: */ +/* > = 'Q': generate Q; */ +/* > = 'P': generate P**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q or P**H to be returned. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q or P**H to be returned. */ +/* > N >= 0. */ +/* > If VECT = 'Q', M >= N >= f2cmin(M,K); */ +/* > if VECT = 'P', N >= M >= f2cmin(N,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > If VECT = 'Q', the number of columns in the original M-by-K */ +/* > matrix reduced by CGEBRD. */ +/* > If VECT = 'P', the number of rows in the original K-by-N */ +/* > matrix reduced by CGEBRD. */ +/* > K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the vectors which define the elementary reflectors, */ +/* > as returned by CGEBRD. */ +/* > On exit, the M-by-N matrix Q or P**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension */ +/* > (f2cmin(M,K)) if VECT = 'Q' */ +/* > (f2cmin(N,K)) if VECT = 'P' */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i) or G(i), which determines Q or P**H, as */ +/* > returned by CGEBRD in its array argument TAUQ or TAUP. */ +/* > \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. LWORK >= f2cmax(1,f2cmin(M,N)). */ +/* > For optimum performance LWORK >= f2cmin(M,N)*NB, where NB */ +/* > is the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complexGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cungbr_(char *vect, integer *m, integer *n, integer *k, + complex *a, integer *lda, complex *tau, complex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + integer iinfo; + logical wantq; + integer mn; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cunglq_( + integer *, integer *, integer *, complex *, integer *, complex *, + complex *, integer *, integer *), cungqr_(integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + integer *); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + wantq = lsame_(vect, "Q"); + mn = f2cmin(*m,*n); + lquery = *lwork == -1; + if (! wantq && ! lsame_(vect, "P")) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0 || wantq && (*n > *m || *n < f2cmin(*m,*k)) || ! wantq && ( + *m > *n || *m < f2cmin(*n,*k))) { + *info = -3; + } else if (*k < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*lwork < f2cmax(1,mn) && ! lquery) { + *info = -9; + } + + if (*info == 0) { + work[1].r = 1.f, work[1].i = 0.f; + if (wantq) { + if (*m >= *k) { + cungqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } else { + if (*m > 1) { + i__1 = *m - 1; + i__2 = *m - 1; + i__3 = *m - 1; + cungqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & + work[1], &c_n1, &iinfo); + } + } + } else { + if (*k < *n) { + cunglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } else { + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + cunglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], & + work[1], &c_n1, &iinfo); + } + } + } + lwkopt = work[1].r; + lwkopt = f2cmax(lwkopt,mn); + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGBR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + + if (wantq) { + +/* Form Q, determined by a call to CGEBRD to reduce an m-by-k */ +/* matrix */ + + if (*m >= *k) { + +/* If m >= k, assume m >= n >= k */ + + cungqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + + } else { + +/* If m < k, assume m = n */ + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the right, and set the first row and column of Q */ +/* to those of the unit matrix */ + + for (j = *m; j >= 2; --j) { + i__1 = j * a_dim1 + 1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + i__1 = *m; + for (i__ = j + 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + i__3 = i__ + (j - 1) * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; +/* L10: */ + } +/* L20: */ + } + i__1 = a_dim1 + 1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L30: */ + } + if (*m > 1) { + +/* Form Q(2:m,2:m) */ + + i__1 = *m - 1; + i__2 = *m - 1; + i__3 = *m - 1; + cungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ + 1], &work[1], lwork, &iinfo); + } + } + } else { + +/* Form P**H, determined by a call to CGEBRD to reduce a k-by-n */ +/* matrix */ + + if (*k < *n) { + +/* If k < n, assume k <= m <= n */ + + cunglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + + } else { + +/* If k >= n, assume m = n */ + +/* Shift the vectors which define the elementary reflectors one */ +/* row downward, and set the first row and column of P**H to */ +/* those of the unit matrix */ + + i__1 = a_dim1 + 1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L40: */ + } + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + for (i__ = j - 1; i__ >= 2; --i__) { + i__2 = i__ + 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; +/* L50: */ + } + i__2 = j * a_dim1 + 1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L60: */ + } + if (*n > 1) { + +/* Form P**H(2:n,2:n) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + cunglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ + 1], &work[1], lwork, &iinfo); + } + } + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNGBR */ + +} /* cungbr_ */ + diff --git a/lapack-netlib/SRC/cunghr.c b/lapack-netlib/SRC/cunghr.c new file mode 100644 index 000000000..61f181df5 --- /dev/null +++ b/lapack-netlib/SRC/cunghr.c @@ -0,0 +1,658 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGHR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGHR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER IHI, ILO, INFO, LDA, LWORK, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGHR generates a complex unitary matrix Q which is defined as the */ +/* > product of IHI-ILO elementary reflectors of order N, as returned by */ +/* > CGEHRD: */ +/* > */ +/* > Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix Q. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > ILO and IHI must have the same values as in the previous call */ +/* > of CGEHRD. Q is equal to the unit matrix except in the */ +/* > submatrix Q(ilo+1:ihi,ilo+1:ihi). */ +/* > 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the vectors which define the elementary reflectors, */ +/* > as returned by CGEHRD. */ +/* > On exit, the N-by-N unitary matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (N-1) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEHRD. */ +/* > \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. LWORK >= IHI-ILO. */ +/* > For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cunghr_(integer *n, integer *ilo, integer *ihi, complex * + a, integer *lda, complex *tau, complex *work, integer *lwork, integer + *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, iinfo, nb, nh; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nh = *ihi - *ilo; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > f2cmax(1,*n)) { + *info = -2; + } else if (*ihi < f2cmin(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*lwork < f2cmax(1,nh) && ! lquery) { + *info = -8; + } + + if (*info == 0) { + nb = ilaenv_(&c__1, "CUNGQR", " ", &nh, &nh, &nh, &c_n1, (ftnlen)6, ( + ftnlen)1); + lwkopt = f2cmax(1,nh) * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGHR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the right, and set the first ilo and the last n-ihi */ +/* rows and columns to those of the unit matrix */ + + i__1 = *ilo + 1; + for (j = *ihi; j >= i__1; --j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } + i__2 = *ihi; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + (j - 1) * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; +/* L20: */ + } + i__2 = *n; + for (i__ = *ihi + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L30: */ + } +/* L40: */ + } + i__1 = *ilo; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L50: */ + } + i__2 = j + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; +/* L60: */ + } + i__1 = *n; + for (j = *ihi + 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L70: */ + } + i__2 = j + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; +/* L80: */ + } + + if (nh > 0) { + +/* Generate Q(ilo+1:ihi,ilo+1:ihi) */ + + cungqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[* + ilo], &work[1], lwork, &iinfo); + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNGHR */ + +} /* cunghr_ */ + diff --git a/lapack-netlib/SRC/cungl2.c b/lapack-netlib/SRC/cungl2.c new file mode 100644 index 000000000..25a9bb456 --- /dev/null +++ b/lapack-netlib/SRC/cungl2.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 \b CUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cge +lqf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGL2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, */ +/* > which is defined as the first m rows of a product of k elementary */ +/* > reflectors of order n */ +/* > */ +/* > Q = H(k)**H . . . H(2)**H H(1)**H */ +/* > */ +/* > as returned by CGELQF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. M >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the i-th row must contain the vector which defines */ +/* > the elementary reflector H(i), for i = 1,2,...,k, as returned */ +/* > by CGELQF in the first k rows of its array argument A. */ +/* > On exit, the m by n matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGELQF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument has 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 cungl2_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + complex q__1, q__2; + + /* Local variables */ + integer i__, j, l; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), clarf_(char *, integer *, integer *, complex *, + integer *, complex *, complex *, integer *, complex *), + clacgv_(integer *, 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 arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGL2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + return 0; + } + + if (*k < *m) { + +/* Initialise rows k+1:m to rows of the unit matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = *k + 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } + if (j > *k && j <= *m) { + i__2 = j + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + } +/* L20: */ + } + } + + for (i__ = *k; i__ >= 1; --i__) { + +/* Apply H(i)**H to A(i:m,i:n) from the right */ + + if (i__ < *n) { + i__1 = *n - i__; + clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); + if (i__ < *m) { + i__1 = i__ + i__ * a_dim1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + i__1 = *m - i__; + i__2 = *n - i__ + 1; + r_cnjg(&q__1, &tau[i__]); + clarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & + q__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); + } + i__1 = *n - i__; + i__2 = i__; + q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i; + cscal_(&i__1, &q__1, &a[i__ + (i__ + 1) * a_dim1], lda); + i__1 = *n - i__; + clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); + } + i__1 = i__ + i__ * a_dim1; + r_cnjg(&q__2, &tau[i__]); + q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Set A(i,1:i-1,i) to zero */ + + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + i__2 = i__ + l * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of CUNGL2 */ + +} /* cungl2_ */ + diff --git a/lapack-netlib/SRC/cunglq.c b/lapack-netlib/SRC/cunglq.c new file mode 100644 index 000000000..8a589ba3c --- /dev/null +++ b/lapack-netlib/SRC/cunglq.c @@ -0,0 +1,720 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGLQ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGLQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, K, LDA, LWORK, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows, */ +/* > which is defined as the first M rows of a product of K elementary */ +/* > reflectors of order N */ +/* > */ +/* > Q = H(k)**H . . . H(2)**H H(1)**H */ +/* > */ +/* > as returned by CGELQF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. M >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the i-th row must contain the vector which defines */ +/* > the elementary reflector H(i), for i = 1,2,...,k, as returned */ +/* > by CGELQF in the first k rows of its array argument A. */ +/* > On exit, the M-by-N matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGELQF. */ +/* > \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. LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= M*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit; */ +/* > < 0: if INFO = -i, the i-th argument has 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 cunglq_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, nbmin, iinfo; + extern /* Subroutine */ int cungl2_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *); + integer ib, nb, ki, kk; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nx; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "CUNGLQ", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = f2cmax(1,*m) * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*lwork < f2cmax(1,*m) && ! lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGLQ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGLQ", " ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGLQ", " ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the last block. */ +/* The first kk rows are handled by the block method. */ + + ki = (*k - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *k, i__2 = ki + nb; + kk = f2cmin(i__1,i__2); + +/* Set A(kk+1:m,1:kk) to zero. */ + + i__1 = kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = kk + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the last or only block. */ + + if (kk < *m) { + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + cungl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & + tau[kk + 1], &work[1], &iinfo); + } + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); + if (i__ + ib <= *m) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__2 = *n - i__ + 1; + clarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H**H to A(i+ib:m,i:n) from the right */ + + i__2 = *m - i__ - ib + 1; + i__3 = *n - i__ + 1; + clarfb_("Right", "Conjugate transpose", "Forward", "Rowwise", + &i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ + ib + 1], &ldwork); + } + +/* Apply H**H to columns i:n of current block */ + + i__2 = *n - i__ + 1; + cungl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); + +/* Set columns 1:i-1 of current block to zero */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + ib - 1; + for (l = i__; l <= i__3; ++l) { + i__4 = l + j * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1].r = (real) iws, work[1].i = 0.f; + return 0; + +/* End of CUNGLQ */ + +} /* cunglq_ */ + diff --git a/lapack-netlib/SRC/cungql.c b/lapack-netlib/SRC/cungql.c new file mode 100644 index 000000000..2d78911b6 --- /dev/null +++ b/lapack-netlib/SRC/cungql.c @@ -0,0 +1,730 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGQL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGQL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, K, LDA, LWORK, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGQL generates an M-by-N complex matrix Q with orthonormal columns, */ +/* > which is defined as the last N columns of a product of K elementary */ +/* > reflectors of order M */ +/* > */ +/* > Q = H(k) . . . H(2) H(1) */ +/* > */ +/* > as returned by CGEQLF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the (n-k+i)-th column must contain the vector which */ +/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by CGEQLF in the last k columns of its array */ +/* > argument A. */ +/* > On exit, the M-by-N matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQLF. */ +/* > \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. LWORK >= f2cmax(1,N). */ +/* > For optimum performance LWORK >= N*NB, where NB is the */ +/* > optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument has 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 cungql_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, j, l, nbmin, iinfo; + extern /* Subroutine */ int cung2l_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *); + integer ib, nb, kk; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nx; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "CUNGQL", " ", m, n, k, &c_n1, (ftnlen)6, ( + ftnlen)1); + lwkopt = *n * nb; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + + if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGQL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGQL", " ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGQL", " ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the first block. */ +/* The last kk columns are handled by the block method. */ + +/* Computing MIN */ + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = f2cmin(i__1,i__2); + +/* Set A(m-kk+1:m,1:n-kk) to zero. */ + + i__1 = *n - kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the first or only block. */ + + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + cung2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) + ; + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); + if (*n - *k + i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *m - *k + i__ + ib - 1; + clarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k + + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ + + i__3 = *m - *k + i__ + ib - 1; + i__4 = *n - *k + i__ - 1; + clarfb_("Left", "No transpose", "Backward", "Columnwise", & + i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], + lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + + 1], &ldwork); + } + +/* Apply H to rows 1:m-k+i+ib-1 of current block */ + + i__3 = *m - *k + i__ + ib - 1; + cung2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & + tau[i__], &work[1], &iinfo); + +/* Set rows m-k+i+ib:m of current block to zero */ + + i__3 = *n - *k + i__ + ib - 1; + for (j = *n - *k + i__; j <= i__3; ++j) { + i__4 = *m; + for (l = *m - *k + i__ + ib; l <= i__4; ++l) { + i__5 = l + j * a_dim1; + a[i__5].r = 0.f, a[i__5].i = 0.f; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1].r = (real) iws, work[1].i = 0.f; + return 0; + +/* End of CUNGQL */ + +} /* cungql_ */ + diff --git a/lapack-netlib/SRC/cungqr.c b/lapack-netlib/SRC/cungqr.c new file mode 100644 index 000000000..0fe95fbd7 --- /dev/null +++ b/lapack-netlib/SRC/cungqr.c @@ -0,0 +1,721 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, K, LDA, LWORK, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGQR generates an M-by-N complex matrix Q with orthonormal columns, */ +/* > which is defined as the first N columns of a product of K elementary */ +/* > reflectors of order M */ +/* > */ +/* > Q = H(1) H(2) . . . H(k) */ +/* > */ +/* > as returned by CGEQRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the i-th column must contain the vector which */ +/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by CGEQRF in the first k columns of its array */ +/* > argument A. */ +/* > On exit, the M-by-N matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQRF. */ +/* > \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. LWORK >= f2cmax(1,N). */ +/* > For optimum performance LWORK >= N*NB, where NB is the */ +/* > optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument has 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 cungqr_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, nbmin, iinfo; + extern /* Subroutine */ int cung2r_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *); + integer ib, nb, ki, kk; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nx; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "CUNGQR", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = f2cmax(1,*n) * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGQR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGQR", " ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGQR", " ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the last block. */ +/* The first kk columns are handled by the block method. */ + + ki = (*k - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *k, i__2 = ki + nb; + kk = f2cmin(i__1,i__2); + +/* Set A(1:kk,kk+1:n) to zero. */ + + i__1 = *n; + for (j = kk + 1; j <= i__1; ++j) { + i__2 = kk; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the last or only block. */ + + if (kk < *n) { + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + cung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & + tau[kk + 1], &work[1], &iinfo); + } + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); + if (i__ + ib <= *n) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__2 = *m - i__ + 1; + clarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(i:m,i+ib:n) from the left */ + + i__2 = *m - i__ + 1; + i__3 = *n - i__ - ib + 1; + clarfb_("Left", "No transpose", "Forward", "Columnwise", & + i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & + work[ib + 1], &ldwork); + } + +/* Apply H to rows i:m of current block */ + + i__2 = *m - i__ + 1; + cung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); + +/* Set rows 1:i-1 of current block to zero */ + + i__2 = i__ + ib - 1; + for (j = i__; j <= i__2; ++j) { + i__3 = i__ - 1; + for (l = 1; l <= i__3; ++l) { + i__4 = l + j * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1].r = (real) iws, work[1].i = 0.f; + return 0; + +/* End of CUNGQR */ + +} /* cungqr_ */ + diff --git a/lapack-netlib/SRC/cungr2.c b/lapack-netlib/SRC/cungr2.c new file mode 100644 index 000000000..aaca1f03a --- /dev/null +++ b/lapack-netlib/SRC/cungr2.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 \b CUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cge +rqf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGR2 generates an m by n complex matrix Q with orthonormal rows, */ +/* > which is defined as the last m rows of a product of k elementary */ +/* > reflectors of order n */ +/* > */ +/* > Q = H(1)**H H(2)**H . . . H(k)**H */ +/* > */ +/* > as returned by CGERQF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. M >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the (m-k+i)-th row must contain the vector which */ +/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by CGERQF in the last k rows of its array argument */ +/* > A. */ +/* > On exit, the m-by-n matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGERQF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument has 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 cungr2_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + complex q__1, q__2; + + /* Local variables */ + integer i__, j, l; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), clarf_(char *, integer *, integer *, complex *, + integer *, complex *, complex *, integer *, complex *); + integer ii; + extern /* Subroutine */ int clacgv_(integer *, 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 arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGR2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + return 0; + } + + if (*k < *m) { + +/* Initialise rows 1:m-k to rows of the unit matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m - *k; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } + if (j > *n - *m && j <= *n - *k) { + i__2 = *m - *n + j + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + } +/* L20: */ + } + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + ii = *m - *k + i__; + +/* Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right */ + + i__2 = *n - *m + ii - 1; + clacgv_(&i__2, &a[ii + a_dim1], lda); + i__2 = ii + (*n - *m + ii) * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + i__2 = ii - 1; + i__3 = *n - *m + ii; + r_cnjg(&q__1, &tau[i__]); + clarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &q__1, &a[ + a_offset], lda, &work[1]); + i__2 = *n - *m + ii - 1; + i__3 = i__; + q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; + cscal_(&i__2, &q__1, &a[ii + a_dim1], lda); + i__2 = *n - *m + ii - 1; + clacgv_(&i__2, &a[ii + a_dim1], lda); + i__2 = ii + (*n - *m + ii) * a_dim1; + r_cnjg(&q__2, &tau[i__]); + q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + +/* Set A(m-k+i,n-k+i+1:n) to zero */ + + i__2 = *n; + for (l = *n - *m + ii + 1; l <= i__2; ++l) { + i__3 = ii + l * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of CUNGR2 */ + +} /* cungr2_ */ + diff --git a/lapack-netlib/SRC/cungrq.c b/lapack-netlib/SRC/cungrq.c new file mode 100644 index 000000000..9a9c2781f --- /dev/null +++ b/lapack-netlib/SRC/cungrq.c @@ -0,0 +1,730 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGRQ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGRQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, K, LDA, LWORK, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGRQ generates an M-by-N complex matrix Q with orthonormal rows, */ +/* > which is defined as the last M rows of a product of K elementary */ +/* > reflectors of order N */ +/* > */ +/* > Q = H(1)**H H(2)**H . . . H(k)**H */ +/* > */ +/* > as returned by CGERQF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix Q. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Q. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines the */ +/* > matrix Q. M >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the (m-k+i)-th row must contain the vector which */ +/* > defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by CGERQF in the last k rows of its array argument */ +/* > A. */ +/* > On exit, the M-by-N matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The first dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGERQF. */ +/* > \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. LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= M*NB, where NB is the */ +/* > optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument has 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 cungrq_(integer *m, integer *n, integer *k, complex *a, + integer *lda, complex *tau, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, j, l, nbmin, iinfo; + extern /* Subroutine */ int cungr2_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *); + integer ib, nb, ii, kk; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nx; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } + + if (*info == 0) { + if (*m <= 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "CUNGRQ", " ", m, n, k, &c_n1, (ftnlen)6, ( + ftnlen)1); + lwkopt = *m * nb; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + + if (*lwork < f2cmax(1,*m) && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGRQ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + return 0; + } + + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGRQ", " ", m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGRQ", " ", m, n, k, &c_n1, + (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the first block. */ +/* The last kk rows are handled by the block method. */ + +/* Computing MIN */ + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = f2cmin(i__1,i__2); + +/* Set A(1:m-kk,n-kk+1:n) to zero. */ + + i__1 = *n; + for (j = *n - kk + 1; j <= i__1; ++j) { + i__2 = *m - kk; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the first or only block. */ + + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + cungr2_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) + ; + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); + ii = *m - *k + i__; + if (ii > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *n - *k + i__ + ib - 1; + clarft_("Backward", "Rowwise", &i__3, &ib, &a[ii + a_dim1], + lda, &tau[i__], &work[1], &ldwork); + +/* Apply H**H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */ + + i__3 = ii - 1; + i__4 = *n - *k + i__ + ib - 1; + clarfb_("Right", "Conjugate transpose", "Backward", "Rowwise", + &i__3, &i__4, &ib, &a[ii + a_dim1], lda, &work[1], & + ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork); + } + +/* Apply H**H to columns 1:n-k+i+ib-1 of current block */ + + i__3 = *n - *k + i__ + ib - 1; + cungr2_(&ib, &i__3, &ib, &a[ii + a_dim1], lda, &tau[i__], &work[1] + , &iinfo); + +/* Set columns n-k+i+ib:n of current block to zero */ + + i__3 = *n; + for (l = *n - *k + i__ + ib; l <= i__3; ++l) { + i__4 = ii + ib - 1; + for (j = ii; j <= i__4; ++j) { + i__5 = j + l * a_dim1; + a[i__5].r = 0.f, a[i__5].i = 0.f; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1].r = (real) iws, work[1].i = 0.f; + return 0; + +/* End of CUNGRQ */ + +} /* cungrq_ */ + diff --git a/lapack-netlib/SRC/cungtr.c b/lapack-netlib/SRC/cungtr.c new file mode 100644 index 000000000..4c23b2b19 --- /dev/null +++ b/lapack-netlib/SRC/cungtr.c @@ -0,0 +1,693 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGTR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGTR generates a complex unitary matrix Q which is defined as the */ +/* > product of n-1 elementary reflectors of order N, as returned by */ +/* > CHETRD: */ +/* > */ +/* > if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ +/* > */ +/* > if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A contains elementary reflectors */ +/* > from CHETRD; */ +/* > = 'L': Lower triangle of A contains elementary reflectors */ +/* > from CHETRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix Q. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the vectors which define the elementary reflectors, */ +/* > as returned by CHETRD. */ +/* > On exit, the N-by-N unitary matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (N-1) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CHETRD. */ +/* > \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. LWORK >= N-1. */ +/* > For optimum performance LWORK >= (N-1)*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cungtr_(char *uplo, integer *n, complex *a, integer *lda, + complex *tau, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + integer iinfo; + logical upper; + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int cungql_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *), + cungqr_(integer *, integer *, integer *, complex *, integer *, + complex *, complex *, integer *, integer *); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + 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(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n - 1; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -7; + } + } + + if (*info == 0) { + if (upper) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "CUNGQL", " ", &i__1, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)1); + } else { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "CUNGQR", " ", &i__1, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)1); + } +/* Computing MAX */ + i__1 = 1, i__2 = *n - 1; + lwkopt = f2cmax(i__1,i__2) * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGTR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + + if (upper) { + +/* Q was determined by a call to CHETRD with UPLO = 'U' */ + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the left, and set the last row and column of Q to */ +/* those of the unit matrix */ + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + (j + 1) * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; +/* L10: */ + } + i__2 = *n + j * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + *n * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L30: */ + } + i__1 = *n + *n * a_dim1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + +/* Generate Q(1:n-1,1:n-1) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + cungql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], + lwork, &iinfo); + + } else { + +/* Q was determined by a call to CHETRD with UPLO = 'L'. */ + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the right, and set the first row and column of Q to */ +/* those of the unit matrix */ + + for (j = *n; j >= 2; --j) { + i__1 = j * a_dim1 + 1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + i__3 = i__ + (j - 1) * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; +/* L40: */ + } +/* L50: */ + } + i__1 = a_dim1 + 1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L60: */ + } + if (*n > 1) { + +/* Generate Q(2:n,2:n) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + cungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], + &work[1], lwork, &iinfo); + } + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNGTR */ + +} /* cungtr_ */ + diff --git a/lapack-netlib/SRC/cungtsqr.c b/lapack-netlib/SRC/cungtsqr.c new file mode 100644 index 000000000..dc9d51b94 --- /dev/null +++ b/lapack-netlib/SRC/cungtsqr.c @@ -0,0 +1,718 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGTSQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGTSQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > */ +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, */ +/* $ INFO ) */ + +/* INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB */ +/* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal */ +/* > columns, which are the first N columns of a product of comlpex unitary */ +/* > matrices of order M which are returned by CLATSQR */ +/* > */ +/* > Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). */ +/* > */ +/* > See the documentation for CLATSQR. */ +/* > \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 used by DLATSQR to return */ +/* > arrays A and T. MB > N. */ +/* > (Note that if MB > M, then M is used instead of MB */ +/* > as the row block size). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size used by CLATSQR to return */ +/* > arrays A and T. NB >= 1. */ +/* > (Note that if NB > N, then N is used instead of NB */ +/* > as the column block size). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > */ +/* > On entry: */ +/* > */ +/* > The elements on and above the diagonal are not accessed. */ +/* > The elements below the diagonal represent the unit */ +/* > lower-trapezoidal blocked matrix V computed by CLATSQR */ +/* > that defines the input matrices Q_in(k) (ones on the */ +/* > diagonal are not stored) (same format as the output A */ +/* > below the diagonal in CLATSQR). */ +/* > */ +/* > On exit: */ +/* > */ +/* > The array A contains an M-by-N orthonormal matrix Q_out, */ +/* > i.e the columns of A are orthogonal unit vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX array, */ +/* > dimension (LDT, N * NIRB) */ +/* > where NIRB = Number_of_input_row_blocks */ +/* > = MAX( 1, CEIL((M-N)/(MB-N)) ) */ +/* > Let NICB = Number_of_input_col_blocks */ +/* > = CEIL(N/NB) */ +/* > */ +/* > The upper-triangular block reflectors used to define the */ +/* > input matrices Q_in(k), k=(1:NIRB*NICB). The block */ +/* > reflectors are stored in compact form in NIRB block */ +/* > reflector sequences. Each of NIRB block reflector sequences */ +/* > is stored in a larger NB-by-N column block of T and consists */ +/* > of NICB smaller NB-by-NB upper-triangular column blocks. */ +/* > (same format as the output T in CLATSQR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. */ +/* > LDT >= f2cmax(1,f2cmin(NB1,N)). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX array, dimension (MAX(2,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. LWORK >= (M+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. */ + +/* > \date November 2019 */ + +/* > \ingroup comlexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2019, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int cungtsqr_(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; + complex q__1; + + /* Local variables */ + extern /* Subroutine */ int clamtsqr_(char *, char *, integer *, integer * + , integer *, integer *, integer *, complex *, integer *, complex * + , integer *, complex *, integer *, complex *, integer *, integer * + ); + integer lworkopt, j, iinfo; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + integer lc, lw; + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + logical lquery; + integer ldc, nblocal; + + +/* -- 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; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + lquery = *lwork == -1; + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *m < *n) { + *info = -2; + } else if (*mb <= *n) { + *info = -3; + } else if (*nb < 1) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = f2cmin(*nb,*n); + if (*ldt < f2cmax(i__1,i__2)) { + *info = -8; + } else { + +/* Test the input LWORK for the dimension of the array WORK. */ +/* This workspace is used to store array C(LDC, N) and WORK(LWORK) */ +/* in the call to CLAMTSQR. See the documentation for CLAMTSQR. */ + + if (*lwork < 2 && ! lquery) { + *info = -10; + } else { + +/* Set block size for column blocks */ + + nblocal = f2cmin(*nb,*n); + +/* LWORK = -1, then set the size for the array C(LDC,N) */ +/* in CLAMTSQR call and set the optimal size of the work array */ +/* WORK(LWORK) in CLAMTSQR call. */ + + ldc = *m; + lc = ldc * *n; + lw = *n * nblocal; + + lworkopt = lc + lw; + + if (*lwork < f2cmax(1,lworkopt) && ! lquery) { + *info = -10; + } + } + + } + } + +/* Handle error in the input parameters and return workspace query. */ + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGTSQR", &i__1, (ftnlen)8); + return 0; + } else if (lquery) { + q__1.r = (real) lworkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + q__1.r = (real) lworkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* (1) Form explicitly the tall-skinny M-by-N left submatrix Q1_in */ +/* of M-by-M orthogonal matrix Q_in, which is implicitly stored in */ +/* the subdiagonal part of input array A and in the input array T. */ +/* Perform by the following operation using the routine CLAMTSQR. */ + +/* Q1_in = Q_in * ( I ), where I is a N-by-N identity matrix, */ +/* ( 0 ) 0 is a (M-N)-by-N zero matrix. */ + +/* (1a) Form M-by-N matrix in the array WORK(1:LDC*N) with ones */ +/* on the diagonal and zeros elsewhere. */ + + claset_("F", m, n, &c_b2, &c_b1, &work[1], &ldc); + +/* (1b) On input, WORK(1:LDC*N) stores ( I ); */ +/* ( 0 ) */ + +/* On output, WORK(1:LDC*N) stores Q1_in. */ + + clamtsqr_("L", "N", m, n, n, mb, &nblocal, &a[a_offset], lda, &t[t_offset] + , ldt, &work[1], &ldc, &work[lc + 1], &lw, &iinfo); + +/* (2) Copy the result from the part of the work array (1:M,1:N) */ +/* with the leading dimension LDC that starts at WORK(1) into */ +/* the output array A(1:M,1:N) column-by-column. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ccopy_(m, &work[(j - 1) * ldc + 1], &c__1, &a[j * a_dim1 + 1], &c__1); + } + + q__1.r = (real) lworkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + +/* End of CUNGTSQR */ + +} /* cungtsqr_ */ + diff --git a/lapack-netlib/SRC/cungtsqr_row.c b/lapack-netlib/SRC/cungtsqr_row.c new file mode 100644 index 000000000..f39ac0f70 --- /dev/null +++ b/lapack-netlib/SRC/cungtsqr_row.c @@ -0,0 +1,800 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNGTSQR_ROW */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNGTSQR_ROW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ +/* > */ +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNGTSQR_ROW( M, N, MB, NB, A, LDA, T, LDT, WORK, */ +/* $ LWORK, INFO ) */ +/* IMPLICIT NONE */ + +/* INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB */ +/* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNGTSQR_ROW generates an M-by-N complex matrix Q_out with */ +/* > orthonormal columns from the output of CLATSQR. These N orthonormal */ +/* > columns are the first N columns of a product of complex unitary */ +/* > matrices Q(k)_in of order M, which are returned by CLATSQR in */ +/* > a special format. */ +/* > */ +/* > Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). */ +/* > */ +/* > The input matrices Q(k)_in are stored in row and column blocks in A. */ +/* > See the documentation of CLATSQR for more details on the format of */ +/* > Q(k)_in, where each Q(k)_in is represented by block Householder */ +/* > transformations. This routine calls an auxiliary routine CLARFB_GETT, */ +/* > where the computation is performed on each individual block. The */ +/* > algorithm first sweeps NB-sized column blocks from the right to left */ +/* > starting in the bottom row block and continues to the top row block */ +/* > (hence _ROW in the routine name). This sweep is in reverse order of */ +/* > the order in which CLATSQR generates the output blocks. */ +/* > \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 used by CLATSQR to return */ +/* > arrays A and T. MB > N. */ +/* > (Note that if MB > M, then M is used instead of MB */ +/* > as the row block size). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size used by CLATSQR to return */ +/* > arrays A and T. NB >= 1. */ +/* > (Note that if NB > N, then N is used instead of NB */ +/* > as the column block size). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > */ +/* > On entry: */ +/* > */ +/* > The elements on and above the diagonal are not used as */ +/* > input. The elements below the diagonal represent the unit */ +/* > lower-trapezoidal blocked matrix V computed by CLATSQR */ +/* > that defines the input matrices Q_in(k) (ones on the */ +/* > diagonal are not stored). See CLATSQR for more details. */ +/* > */ +/* > On exit: */ +/* > */ +/* > The array A contains an M-by-N orthonormal matrix Q_out, */ +/* > i.e the columns of A are orthogonal unit vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX array, */ +/* > dimension (LDT, N * NIRB) */ +/* > where NIRB = Number_of_input_row_blocks */ +/* > = MAX( 1, CEIL((M-N)/(MB-N)) ) */ +/* > Let NICB = Number_of_input_col_blocks */ +/* > = CEIL(N/NB) */ +/* > */ +/* > The upper-triangular block reflectors used to define the */ +/* > input matrices Q_in(k), k=(1:NIRB*NICB). The block */ +/* > reflectors are stored in compact form in NIRB block */ +/* > reflector sequences. Each of the NIRB block reflector */ +/* > sequences is stored in a larger NB-by-N column block of T */ +/* > and consists of NICB smaller NB-by-NB upper-triangular */ +/* > column blocks. See CLATSQR for more details on the format */ +/* > of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. */ +/* > LDT >= f2cmax(1,f2cmin(NB,N)). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. */ +/* > LWORK >= NBLOCAL * MAX(NBLOCAL,(N-NBLOCAL)), */ +/* > where NBLOCAL=MIN(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. */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2020, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cungtsqr_row_(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, i__4, i__5; + complex q__1; + + /* Local variables */ + integer jb_t__, itmp, lworkopt; + complex dummy[1] /* was [1][1] */; + integer ib_bottom__, ib, kb; + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + integer mb1, mb2, m_plus_one__; + logical lquery; + integer num_all_row_blocks__, imb, knb, nblocal, kb_last__; + extern /* Subroutine */ int clarfb_gett_(char *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *); + + +/* -- LAPACK computational routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* 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) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = f2cmin(*nb,*n); + if (*ldt < f2cmax(i__1,i__2)) { + *info = -8; + } else if (*lwork < 1 && ! lquery) { + *info = -10; + } + } + + nblocal = f2cmin(*nb,*n); + +/* Determine the workspace size. */ + + if (*info == 0) { +/* Computing MAX */ + i__1 = nblocal, i__2 = *n - nblocal; + lworkopt = nblocal * f2cmax(i__1,i__2); + } + +/* Handle error in the input parameters and handle the workspace query. */ + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNGTSQR_ROW", &i__1, (ftnlen)12); + return 0; + } else if (lquery) { + q__1.r = (real) lworkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + q__1.r = (real) lworkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* (0) Set the upper-triangular part of the matrix A to zero and */ +/* its diagonal elements to one. */ + + claset_("U", m, n, &c_b2, &c_b1, &a[a_offset], lda); + +/* KB_LAST is the column index of the last column block reflector */ +/* in the matrices T and V. */ + + kb_last__ = (*n - 1) / nblocal * nblocal + 1; + + +/* (1) Bottom-up loop over row blocks of A, except the top row block. */ +/* NOTE: If MB>=M, then the loop is never executed. */ + + if (*mb < *m) { + +/* MB2 is the row blocking size for the row blocks before the */ +/* first top row block in the matrix A. IB is the row index for */ +/* the row blocks in the matrix A before the first top row block. */ +/* IB_BOTTOM is the row index for the last bottom row block */ +/* in the matrix A. JB_T is the column index of the corresponding */ +/* column block in the matrix T. */ + +/* Initialize variables. */ + +/* NUM_ALL_ROW_BLOCKS is the number of row blocks in the matrix A */ +/* including the first row block. */ + + mb2 = *mb - *n; + m_plus_one__ = *m + 1; + itmp = (*m - *mb - 1) / mb2; + ib_bottom__ = itmp * mb2 + *mb + 1; + num_all_row_blocks__ = itmp + 2; + jb_t__ = num_all_row_blocks__ * *n + 1; + + i__1 = *mb + 1; + i__2 = -mb2; + for (ib = ib_bottom__; i__2 < 0 ? ib >= i__1 : ib <= i__1; ib += i__2) + { + +/* Determine the block size IMB for the current row block */ +/* in the matrix A. */ + +/* Computing MIN */ + i__3 = m_plus_one__ - ib; + imb = f2cmin(i__3,mb2); + +/* Determine the column index JB_T for the current column block */ +/* in the matrix T. */ + + jb_t__ -= *n; + +/* Apply column blocks of H in the row block from right to left. */ + +/* KB is the column index of the current column block reflector */ +/* in the matrices T and V. */ + + i__3 = -nblocal; + for (kb = kb_last__; i__3 < 0 ? kb >= 1 : kb <= 1; kb += i__3) { + +/* Determine the size of the current column block KNB in */ +/* the matrices T and V. */ + +/* Computing MIN */ + i__4 = nblocal, i__5 = *n - kb + 1; + knb = f2cmin(i__4,i__5); + + i__4 = *n - kb + 1; + clarfb_gett_("I", &imb, &i__4, &knb, &t[(jb_t__ + kb - 1) * + t_dim1 + 1], ldt, &a[kb + kb * a_dim1], lda, &a[ib + + kb * a_dim1], lda, &work[1], &knb); + + } + + } + + } + +/* (2) Top row block of A. */ +/* NOTE: If MB>=M, then we have only one row block of A of size M */ +/* and we work on the entire matrix A. */ + + mb1 = f2cmin(*mb,*m); + +/* Apply column blocks of H in the top row block from right to left. */ + +/* KB is the column index of the current block reflector in */ +/* the matrices T and V. */ + + i__2 = -nblocal; + for (kb = kb_last__; i__2 < 0 ? kb >= 1 : kb <= 1; kb += i__2) { + +/* Determine the size of the current column block KNB in */ +/* the matrices T and V. */ + +/* Computing MIN */ + i__1 = nblocal, i__3 = *n - kb + 1; + knb = f2cmin(i__1,i__3); + + if (mb1 - kb - knb + 1 == 0) { + +/* In SLARFB_GETT parameters, when M=0, then the matrix B */ +/* does not exist, hence we need to pass a dummy array */ +/* reference DUMMY(1,1) to B with LDDUMMY=1. */ + + i__1 = *n - kb + 1; + clarfb_gett_("N", &c__0, &i__1, &knb, &t[kb * t_dim1 + 1], ldt, & + a[kb + kb * a_dim1], lda, dummy, &c__1, &work[1], &knb); + } else { + i__1 = mb1 - kb - knb + 1; + i__3 = *n - kb + 1; + clarfb_gett_("N", &i__1, &i__3, &knb, &t[kb * t_dim1 + 1], ldt, & + a[kb + kb * a_dim1], lda, &a[kb + knb + kb * a_dim1], lda, + &work[1], &knb); + } + + } + + q__1.r = (real) lworkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + +/* End of CUNGTSQR_ROW */ + +} /* cungtsqr_row__ */ + diff --git a/lapack-netlib/SRC/cunhr_col.c b/lapack-netlib/SRC/cunhr_col.c new file mode 100644 index 000000000..b82bb73bf --- /dev/null +++ b/lapack-netlib/SRC/cunhr_col.c @@ -0,0 +1,861 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNHR_COL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNHR_COL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > */ +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNHR_COL( M, N, NB, A, LDA, T, LDT, D, INFO ) */ + +/* INTEGER INFO, LDA, LDT, M, N, NB */ +/* COMPLEX A( LDA, * ), D( * ), T( LDT, * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNHR_COL takes an M-by-N complex matrix Q_in with orthonormal columns */ +/* > as input, stored in A, and performs Householder Reconstruction (HR), */ +/* > i.e. reconstructs Householder vectors V(i) implicitly representing */ +/* > another M-by-N matrix Q_out, with the property that Q_in = Q_out*S, */ +/* > where S is an N-by-N diagonal matrix with diagonal entries */ +/* > equal to +1 or -1. The Householder vectors (columns V(i) of V) are */ +/* > stored in A on output, and the diagonal entries of S are stored in D. */ +/* > Block reflectors are also returned in T */ +/* > (same output format as CGEQRT). */ +/* > \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] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the reconstruction */ +/* > of Householder column vector blocks in the array A and */ +/* > corresponding block reflectors in the array T. NB >= 1. */ +/* > (Note that if NB > N, then N is used instead of NB */ +/* > as the column block size.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > */ +/* > On entry: */ +/* > */ +/* > The array A contains an M-by-N orthonormal matrix Q_in, */ +/* > i.e the columns of A are orthogonal unit vectors. */ +/* > */ +/* > On exit: */ +/* > */ +/* > The elements below the diagonal of A represent the unit */ +/* > lower-trapezoidal matrix V of Householder column vectors */ +/* > V(i). The unit diagonal entries of V are not stored */ +/* > (same format as the output below the diagonal in A from */ +/* > CGEQRT). The matrix T and the matrix V stored on output */ +/* > in A implicitly define Q_out. */ +/* > */ +/* > The elements above the diagonal contain the factor U */ +/* > of the "modified" LU-decomposition: */ +/* > Q_in - ( S ) = V * U */ +/* > ( 0 ) */ +/* > where 0 is a (M-N)-by-(M-N) zero matrix. */ +/* > \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) */ +/* > */ +/* > Let NOCB = Number_of_output_col_blocks */ +/* > = CEIL(N/NB) */ +/* > */ +/* > On exit, T(1:NB, 1:N) contains NOCB upper-triangular */ +/* > block reflectors used to define Q_out stored in compact */ +/* > form as a sequence of upper-triangular NB-by-NB column */ +/* > blocks (same format as the output T in CGEQRT). */ +/* > The matrix T and the matrix V stored on output in A */ +/* > implicitly define Q_out. NOTE: The lower triangles */ +/* > below the upper-triangular blcoks will be filled with */ +/* > zeros. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. */ +/* > LDT >= f2cmax(1,f2cmin(NB,N)). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension f2cmin(M,N). */ +/* > The elements can be only plus or minus one. */ +/* > */ +/* > D(i) is constructed as D(i) = -SIGN(Q_in_i(i,i)), where */ +/* > 1 <= i <= f2cmin(M,N), and Q_in_i is Q_in after performing */ +/* > i-1 steps of “modified” Gaussian elimination. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ +/* > */ +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The computed M-by-M unitary factor Q_out is defined implicitly as */ +/* > a product of unitary matrices Q_out(i). Each Q_out(i) is stored in */ +/* > the compact WY-representation format in the corresponding blocks of */ +/* > matrices V (stored in A) and T. */ +/* > */ +/* > The M-by-N unit lower-trapezoidal matrix V stored in the M-by-N */ +/* > matrix A contains the column vectors V(i) in NB-size column */ +/* > blocks VB(j). For example, VB(1) contains the columns */ +/* > V(1), V(2), ... V(NB). NOTE: The unit entries on */ +/* > the diagonal of Y are not stored in A. */ +/* > */ +/* > The number of column blocks is */ +/* > */ +/* > NOCB = Number_of_output_col_blocks = CEIL(N/NB) */ +/* > */ +/* > where each block is of order NB except for the last block, which */ +/* > is of order LAST_NB = N - (NOCB-1)*NB. */ +/* > */ +/* > For example, if M=6, N=5 and NB=2, the matrix V is */ +/* > */ +/* > */ +/* > V = ( VB(1), VB(2), VB(3) ) = */ +/* > */ +/* > = ( 1 ) */ +/* > ( v21 1 ) */ +/* > ( v31 v32 1 ) */ +/* > ( v41 v42 v43 1 ) */ +/* > ( v51 v52 v53 v54 1 ) */ +/* > ( v61 v62 v63 v54 v65 ) */ +/* > */ +/* > */ +/* > For each of the column blocks VB(i), an upper-triangular block */ +/* > reflector TB(i) is computed. These blocks are stored as */ +/* > a sequence of upper-triangular column blocks in the NB-by-N */ +/* > matrix T. The size of each TB(i) block is NB-by-NB, except */ +/* > for the last block, whose size is LAST_NB-by-LAST_NB. */ +/* > */ +/* > For example, if M=6, N=5 and NB=2, the matrix T is */ +/* > */ +/* > T = ( TB(1), TB(2), TB(3) ) = */ +/* > */ +/* > = ( t11 t12 t13 t14 t15 ) */ +/* > ( t22 t24 ) */ +/* > */ +/* > */ +/* > The M-by-M factor Q_out is given as a product of NOCB */ +/* > unitary M-by-M matrices Q_out(i). */ +/* > */ +/* > Q_out = Q_out(1) * Q_out(2) * ... * Q_out(NOCB), */ +/* > */ +/* > where each matrix Q_out(i) is given by the WY-representation */ +/* > using corresponding blocks from the matrices V and T: */ +/* > */ +/* > Q_out(i) = I - VB(i) * TB(i) * (VB(i))**T, */ +/* > */ +/* > where I is the identity matrix. Here is the formula with matrix */ +/* > dimensions: */ +/* > */ +/* > Q(i){M-by-M} = I{M-by-M} - */ +/* > VB(i){M-by-INB} * TB(i){INB-by-INB} * (VB(i))**T {INB-by-M}, */ +/* > */ +/* > where INB = NB, except for the last block NOCB */ +/* > for which INB=LAST_NB. */ +/* > */ +/* > ===== */ +/* > NOTE: */ +/* > ===== */ +/* > */ +/* > If Q_in is the result of doing a QR factorization */ +/* > B = Q_in * R_in, then: */ +/* > */ +/* > B = (Q_out*S) * R_in = Q_out * (S * R_in) = O_out * R_out. */ +/* > */ +/* > So if one wants to interpret Q_out as the result */ +/* > of the QR factorization of B, then corresponding R_out */ +/* > should be obtained by R_out = S * R_in, i.e. some rows of R_in */ +/* > should be multiplied by -1. */ +/* > */ +/* > For the details of the algorithm, see [1]. */ +/* > */ +/* > [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 */ +/* > */ +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complexOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2019, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int cunhr_col_(integer *m, integer *n, integer *nb, complex + *a, integer *lda, complex *t, integer *ldt, complex *d__, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1; + + /* Local variables */ + extern /* Subroutine */ int claunhr_col_getrfnp_(integer *, integer *, + complex *, integer *, complex *, integer *); + integer nplusone, i__, j; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + integer iinfo; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *), ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer jb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer jbtemp1, jbtemp2, jnb; + + +/* -- 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; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --d__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*nb < 1) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = f2cmin(*nb,*n); + if (*ldt < f2cmax(i__1,i__2)) { + *info = -7; + } + } + +/* Handle error in the input parameters. */ + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNHR_COL", &i__1, (ftnlen)9); + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* On input, the M-by-N matrix A contains the unitary */ +/* M-by-N matrix Q_in. */ + +/* (1) Compute the unit lower-trapezoidal V (ones on the diagonal */ +/* are not stored) by performing the "modified" LU-decomposition. */ + +/* Q_in - ( S ) = V * U = ( V1 ) * U, */ +/* ( 0 ) ( V2 ) */ + +/* where 0 is an (M-N)-by-N zero matrix. */ + +/* (1-1) Factor V1 and U. */ + claunhr_col_getrfnp_(n, n, &a[a_offset], lda, &d__[1], &iinfo); + +/* (1-2) Solve for V2. */ + + if (*m > *n) { + i__1 = *m - *n; + ctrsm_("R", "U", "N", "N", &i__1, n, &c_b1, &a[a_offset], lda, &a[*n + + 1 + a_dim1], lda); + } + +/* (2) Reconstruct the block reflector T stored in T(1:NB, 1:N) */ +/* as a sequence of upper-triangular blocks with NB-size column */ +/* blocking. */ + +/* Loop over the column blocks of size NB of the array A(1:M,1:N) */ +/* and the array T(1:NB,1:N), JB is the column index of a column */ +/* block, JNB is the column block size at each step JB. */ + + nplusone = *n + 1; + i__1 = *n; + i__2 = *nb; + for (jb = 1; i__2 < 0 ? jb >= i__1 : jb <= i__1; jb += i__2) { + +/* (2-0) Determine the column block size JNB. */ + +/* Computing MIN */ + i__3 = nplusone - jb; + jnb = f2cmin(i__3,*nb); + +/* (2-1) Copy the upper-triangular part of the current JNB-by-JNB */ +/* diagonal block U(JB) (of the N-by-N matrix U) stored */ +/* in A(JB:JB+JNB-1,JB:JB+JNB-1) into the upper-triangular part */ +/* of the current JNB-by-JNB block T(1:JNB,JB:JB+JNB-1) */ +/* column-by-column, total JNB*(JNB+1)/2 elements. */ + + jbtemp1 = jb - 1; + i__3 = jb + jnb - 1; + for (j = jb; j <= i__3; ++j) { + i__4 = j - jbtemp1; + ccopy_(&i__4, &a[jb + j * a_dim1], &c__1, &t[j * t_dim1 + 1], & + c__1); + } + +/* (2-2) Perform on the upper-triangular part of the current */ +/* JNB-by-JNB diagonal block U(JB) (of the N-by-N matrix U) stored */ +/* in T(1:JNB,JB:JB+JNB-1) the following operation in place: */ +/* (-1)*U(JB)*S(JB), i.e the result will be stored in the upper- */ +/* triangular part of T(1:JNB,JB:JB+JNB-1). This multiplication */ +/* of the JNB-by-JNB diagonal block U(JB) by the JNB-by-JNB */ +/* diagonal block S(JB) of the N-by-N sign matrix S from the */ +/* right means changing the sign of each J-th column of the block */ +/* U(JB) according to the sign of the diagonal element of the block */ +/* S(JB), i.e. S(J,J) that is stored in the array element D(J). */ + + i__3 = jb + jnb - 1; + for (j = jb; j <= i__3; ++j) { + i__4 = j; + if (d__[i__4].r == 1.f && d__[i__4].i == 0.f) { + i__4 = j - jbtemp1; + q__1.r = -1.f, q__1.i = 0.f; + cscal_(&i__4, &q__1, &t[j * t_dim1 + 1], &c__1); + } + } + +/* (2-3) Perform the triangular solve for the current block */ +/* matrix X(JB): */ + +/* X(JB) * (A(JB)**T) = B(JB), where: */ + +/* A(JB)**T is a JNB-by-JNB unit upper-triangular */ +/* coefficient block, and A(JB)=V1(JB), which */ +/* is a JNB-by-JNB unit lower-triangular block */ +/* stored in A(JB:JB+JNB-1,JB:JB+JNB-1). */ +/* The N-by-N matrix V1 is the upper part */ +/* of the M-by-N lower-trapezoidal matrix V */ +/* stored in A(1:M,1:N); */ + +/* B(JB) is a JNB-by-JNB upper-triangular right-hand */ +/* side block, B(JB) = (-1)*U(JB)*S(JB), and */ +/* B(JB) is stored in T(1:JNB,JB:JB+JNB-1); */ + +/* X(JB) is a JNB-by-JNB upper-triangular solution */ +/* block, X(JB) is the upper-triangular block */ +/* reflector T(JB), and X(JB) is stored */ +/* in T(1:JNB,JB:JB+JNB-1). */ + +/* In other words, we perform the triangular solve for the */ +/* upper-triangular block T(JB): */ + +/* T(JB) * (V1(JB)**T) = (-1)*U(JB)*S(JB). */ + +/* Even though the blocks X(JB) and B(JB) are upper- */ +/* triangular, the routine CTRSM will access all JNB**2 */ +/* elements of the square T(1:JNB,JB:JB+JNB-1). Therefore, */ +/* we need to set to zero the elements of the block */ +/* T(1:JNB,JB:JB+JNB-1) below the diagonal before the call */ +/* to CTRSM. */ + +/* (2-3a) Set the elements to zero. */ + + jbtemp2 = jb - 2; + i__3 = jb + jnb - 2; + for (j = jb; j <= i__3; ++j) { + i__4 = *nb; + for (i__ = j - jbtemp2; i__ <= i__4; ++i__) { + i__5 = i__ + j * t_dim1; + t[i__5].r = 0.f, t[i__5].i = 0.f; + } + } + +/* (2-3b) Perform the triangular solve. */ + + ctrsm_("R", "L", "C", "U", &jnb, &jnb, &c_b1, &a[jb + jb * a_dim1], + lda, &t[jb * t_dim1 + 1], ldt); + + } + + return 0; + +/* End of CUNHR_COL */ + +} /* cunhr_col__ */ + diff --git a/lapack-netlib/SRC/cunm22.c b/lapack-netlib/SRC/cunm22.c new file mode 100644 index 000000000..c18896039 --- /dev/null +++ b/lapack-netlib/SRC/cunm22.c @@ -0,0 +1,864 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNM22 multiplies a general matrix by a banded unitary matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNM22 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, */ +/* $ WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO */ +/* COMPLEX Q( LDQ, * ), C( LDC, * ), WORK( * ) */ + +/* > \par Purpose */ +/* ============ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNM22 overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix of order NQ, with NQ = M if */ +/* > SIDE = 'L' and NQ = N if SIDE = 'R'. */ +/* > The unitary matrix Q processes a 2-by-2 block structure */ +/* > */ +/* > [ Q11 Q12 ] */ +/* > Q = [ ] */ +/* > [ Q21 Q22 ], */ +/* > */ +/* > where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an */ +/* > N2-by-N2 upper triangular matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply Q (No transpose); */ +/* > = 'C': apply Q**H (Conjugate transpose). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > N2 is INTEGER */ +/* > The dimension of Q12 and Q21, respectively. N1, N2 >= 0. */ +/* > The following requirement must be satisfied: */ +/* > N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension */ +/* > (LDQ,M) if SIDE = 'L' */ +/* > (LDQ,N) if SIDE = 'R' */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= f2cmax(1,M) if SIDE = 'L'; LDQ >= f2cmax(1,N) if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= M*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. */ + +/* > \date January 2015 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cunm22_(char *side, char *trans, integer *m, integer *n, + integer *n1, integer *n2, complex *q, integer *ldq, complex *c__, + integer *ldc, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4; + complex q__1; + + /* Local variables */ + logical left; + integer i__; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + integer nb, nq, nw; + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), xerbla_(char *, + integer *, ftnlen); + logical notran; + integer ldwork, lwkopt; + logical lquery; + integer len; + + +/* -- 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..-- */ +/* January 2015 */ + + + +/* ===================================================================== */ + + + +/* Test the input arguments */ + + /* Parameter adjustments */ + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q; */ +/* NW is the minimum dimension of WORK. */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + nw = nq; + if (*n1 == 0 || *n2 == 0) { + nw = 1; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*n1 < 0 || *n1 + *n2 != nq) { + *info = -5; + } else if (*n2 < 0) { + *info = -6; + } else if (*ldq < f2cmax(1,nq)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*lwork < nw && ! lquery) { + *info = -12; + } + + if (*info == 0) { + lwkopt = *m * *n; + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNM22", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + +/* Degenerate cases (N1 = 0 or N2 = 0) are handled using CTRMM. */ + + if (*n1 == 0) { + ctrmm_(side, "Upper", trans, "Non-Unit", m, n, &c_b1, &q[q_offset], + ldq, &c__[c_offset], ldc); + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } else if (*n2 == 0) { + ctrmm_(side, "Lower", trans, "Non-Unit", m, n, &c_b1, &q[q_offset], + ldq, &c__[c_offset], ldc); + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + +/* Compute the largest chunk size available from the workspace. */ + +/* Computing MAX */ + i__1 = 1, i__2 = f2cmin(*lwork,lwkopt) / nq; + nb = f2cmax(i__1,i__2); + + if (left) { + if (notran) { + 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; + len = f2cmin(i__3,i__4); + ldwork = *m; + +/* Multiply bottom part of C by Q12. */ + + clacpy_("All", n1, &len, &c__[*n2 + 1 + i__ * c_dim1], ldc, & + work[1], &ldwork); + ctrmm_("Left", "Lower", "No Transpose", "Non-Unit", n1, &len, + &c_b1, &q[(*n2 + 1) * q_dim1 + 1], ldq, &work[1], & + ldwork); + +/* Multiply top part of C by Q11. */ + + cgemm_("No Transpose", "No Transpose", n1, &len, n2, &c_b1, & + q[q_offset], ldq, &c__[i__ * c_dim1 + 1], ldc, &c_b1, + &work[1], &ldwork); + +/* Multiply top part of C by Q21. */ + + clacpy_("All", n2, &len, &c__[i__ * c_dim1 + 1], ldc, &work[* + n1 + 1], &ldwork); + ctrmm_("Left", "Upper", "No Transpose", "Non-Unit", n2, &len, + &c_b1, &q[*n1 + 1 + q_dim1], ldq, &work[*n1 + 1], & + ldwork); + +/* Multiply bottom part of C by Q22. */ + + cgemm_("No Transpose", "No Transpose", n2, &len, n1, &c_b1, & + q[*n1 + 1 + (*n2 + 1) * q_dim1], ldq, &c__[*n2 + 1 + + i__ * c_dim1], ldc, &c_b1, &work[*n1 + 1], &ldwork); + +/* Copy everything back. */ + + clacpy_("All", m, &len, &work[1], &ldwork, &c__[i__ * c_dim1 + + 1], ldc); + } + } else { + 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; + len = f2cmin(i__3,i__4); + ldwork = *m; + +/* Multiply bottom part of C by Q21**H. */ + + clacpy_("All", n2, &len, &c__[*n1 + 1 + i__ * c_dim1], ldc, & + work[1], &ldwork); + ctrmm_("Left", "Upper", "Conjugate", "Non-Unit", n2, &len, & + c_b1, &q[*n1 + 1 + q_dim1], ldq, &work[1], &ldwork); + +/* Multiply top part of C by Q11**H. */ + + cgemm_("Conjugate", "No Transpose", n2, &len, n1, &c_b1, &q[ + q_offset], ldq, &c__[i__ * c_dim1 + 1], ldc, &c_b1, & + work[1], &ldwork); + +/* Multiply top part of C by Q12**H. */ + + clacpy_("All", n1, &len, &c__[i__ * c_dim1 + 1], ldc, &work[* + n2 + 1], &ldwork); + ctrmm_("Left", "Lower", "Conjugate", "Non-Unit", n1, &len, & + c_b1, &q[(*n2 + 1) * q_dim1 + 1], ldq, &work[*n2 + 1], + &ldwork); + +/* Multiply bottom part of C by Q22**H. */ + + cgemm_("Conjugate", "No Transpose", n1, &len, n2, &c_b1, &q[* + n1 + 1 + (*n2 + 1) * q_dim1], ldq, &c__[*n1 + 1 + i__ + * c_dim1], ldc, &c_b1, &work[*n2 + 1], &ldwork); + +/* Copy everything back. */ + + clacpy_("All", m, &len, &work[1], &ldwork, &c__[i__ * c_dim1 + + 1], ldc); + } + } + } else { + if (notran) { + i__1 = *m; + 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 = *m - i__ + 1; + len = f2cmin(i__3,i__4); + ldwork = len; + +/* Multiply right part of C by Q21. */ + + clacpy_("All", &len, n2, &c__[i__ + (*n1 + 1) * c_dim1], ldc, + &work[1], &ldwork); + ctrmm_("Right", "Upper", "No Transpose", "Non-Unit", &len, n2, + &c_b1, &q[*n1 + 1 + q_dim1], ldq, &work[1], &ldwork); + +/* Multiply left part of C by Q11. */ + + cgemm_("No Transpose", "No Transpose", &len, n2, n1, &c_b1, & + c__[i__ + c_dim1], ldc, &q[q_offset], ldq, &c_b1, & + work[1], &ldwork); + +/* Multiply left part of C by Q12. */ + + clacpy_("All", &len, n1, &c__[i__ + c_dim1], ldc, &work[*n2 * + ldwork + 1], &ldwork); + ctrmm_("Right", "Lower", "No Transpose", "Non-Unit", &len, n1, + &c_b1, &q[(*n2 + 1) * q_dim1 + 1], ldq, &work[*n2 * + ldwork + 1], &ldwork); + +/* Multiply right part of C by Q22. */ + + cgemm_("No Transpose", "No Transpose", &len, n1, n2, &c_b1, & + c__[i__ + (*n1 + 1) * c_dim1], ldc, &q[*n1 + 1 + (*n2 + + 1) * q_dim1], ldq, &c_b1, &work[*n2 * ldwork + 1], & + ldwork); + +/* Copy everything back. */ + + clacpy_("All", &len, n, &work[1], &ldwork, &c__[i__ + c_dim1], + ldc); + } + } else { + i__2 = *m; + 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 = *m - i__ + 1; + len = f2cmin(i__3,i__4); + ldwork = len; + +/* Multiply right part of C by Q12**H. */ + + clacpy_("All", &len, n1, &c__[i__ + (*n2 + 1) * c_dim1], ldc, + &work[1], &ldwork); + ctrmm_("Right", "Lower", "Conjugate", "Non-Unit", &len, n1, & + c_b1, &q[(*n2 + 1) * q_dim1 + 1], ldq, &work[1], & + ldwork); + +/* Multiply left part of C by Q11**H. */ + + cgemm_("No Transpose", "Conjugate", &len, n1, n2, &c_b1, &c__[ + i__ + c_dim1], ldc, &q[q_offset], ldq, &c_b1, &work[1] + , &ldwork); + +/* Multiply left part of C by Q21**H. */ + + clacpy_("All", &len, n2, &c__[i__ + c_dim1], ldc, &work[*n1 * + ldwork + 1], &ldwork); + ctrmm_("Right", "Upper", "Conjugate", "Non-Unit", &len, n2, & + c_b1, &q[*n1 + 1 + q_dim1], ldq, &work[*n1 * ldwork + + 1], &ldwork); + +/* Multiply right part of C by Q22**H. */ + + cgemm_("No Transpose", "Conjugate", &len, n2, n1, &c_b1, &c__[ + i__ + (*n2 + 1) * c_dim1], ldc, &q[*n1 + 1 + (*n2 + 1) + * q_dim1], ldq, &c_b1, &work[*n1 * ldwork + 1], & + ldwork); + +/* Copy everything back. */ + + clacpy_("All", &len, n, &work[1], &ldwork, &c__[i__ + c_dim1], + ldc); + } + } + } + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + +/* End of CUNM22 */ + +} /* cunm22_ */ + diff --git a/lapack-netlib/SRC/cunm2l.c b/lapack-netlib/SRC/cunm2l.c new file mode 100644 index 000000000..25a00ca67 --- /dev/null +++ b/lapack-netlib/SRC/cunm2l.c @@ -0,0 +1,687 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by +cgeqlf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNM2L + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNM2L overwrites the general complex m-by-n matrix C with */ +/* > */ +/* > Q * C if SIDE = 'L' and TRANS = 'N', or */ +/* > */ +/* > Q**H* C if SIDE = 'L' and TRANS = 'C', or */ +/* > */ +/* > C * Q if SIDE = 'R' and TRANS = 'N', or */ +/* > */ +/* > C * Q**H if SIDE = 'R' and TRANS = 'C', */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(k) . . . H(2) H(1) */ +/* > */ +/* > as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left */ +/* > = 'R': apply Q or Q**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply Q (No transpose) */ +/* > = 'C': apply Q**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGEQLF in the last k columns of its array argument A. */ +/* > A is modified by the routine but restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQLF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the m-by-n matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (N) if SIDE = 'L', */ +/* > (M) if SIDE = 'R' */ +/* > \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 cunm2l_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + logical left; + complex taui; + integer i__; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *); + extern logical lsame_(char *, char *); + integer i1, i2, i3, mi, ni, nq; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + complex aii; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,nq)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNM2L", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) or H(i)**H is applied to C(1:m-k+i,1:n) */ + + mi = *m - *k + i__; + } else { + +/* H(i) or H(i)**H is applied to C(1:m,1:n-k+i) */ + + ni = *n - *k + i__; + } + +/* Apply H(i) or H(i)**H */ + + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + r_cnjg(&q__1, &tau[i__]); + taui.r = q__1.r, taui.i = q__1.i; + } + i__3 = nq - *k + i__ + i__ * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = nq - *k + i__ + i__ * a_dim1; + a[i__3].r = 1.f, a[i__3].i = 0.f; + clarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &taui, &c__[ + c_offset], ldc, &work[1]); + i__3 = nq - *k + i__ + i__ * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; +/* L10: */ + } + return 0; + +/* End of CUNM2L */ + +} /* cunm2l_ */ + diff --git a/lapack-netlib/SRC/cunm2r.c b/lapack-netlib/SRC/cunm2r.c new file mode 100644 index 000000000..e1c4b0491 --- /dev/null +++ b/lapack-netlib/SRC/cunm2r.c @@ -0,0 +1,691 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by +cgeqrf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNM2R + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNM2R overwrites the general complex m-by-n matrix C with */ +/* > */ +/* > Q * C if SIDE = 'L' and TRANS = 'N', or */ +/* > */ +/* > Q**H* C if SIDE = 'L' and TRANS = 'C', or */ +/* > */ +/* > C * Q if SIDE = 'R' and TRANS = 'N', or */ +/* > */ +/* > C * Q**H if SIDE = 'R' and TRANS = 'C', */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k) */ +/* > */ +/* > as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left */ +/* > = 'R': apply Q or Q**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply Q (No transpose) */ +/* > = 'C': apply Q**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGEQRF in the first k columns of its array argument A. */ +/* > A is modified by the routine but restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the m-by-n matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (N) if SIDE = 'L', */ +/* > (M) if SIDE = 'R' */ +/* > \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 cunm2r_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + logical left; + complex taui; + integer i__; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *); + extern logical lsame_(char *, char *); + integer i1, i2, i3, ic, jc, mi, ni, nq; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + complex aii; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,nq)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNM2R", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) or H(i)**H is applied to C(i:m,1:n) */ + + mi = *m - i__ + 1; + ic = i__; + } else { + +/* H(i) or H(i)**H is applied to C(1:m,i:n) */ + + ni = *n - i__ + 1; + jc = i__; + } + +/* Apply H(i) or H(i)**H */ + + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + r_cnjg(&q__1, &tau[i__]); + taui.r = q__1.r, taui.i = q__1.i; + } + i__3 = i__ + i__ * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = i__ + i__ * a_dim1; + a[i__3].r = 1.f, a[i__3].i = 0.f; + clarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic + + jc * c_dim1], ldc, &work[1]); + i__3 = i__ + i__ * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; +/* L10: */ + } + return 0; + +/* End of CUNM2R */ + +} /* cunm2r_ */ + diff --git a/lapack-netlib/SRC/cunmbr.c b/lapack-netlib/SRC/cunmbr.c new file mode 100644 index 000000000..107a2959f --- /dev/null +++ b/lapack-netlib/SRC/cunmbr.c @@ -0,0 +1,821 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMBR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMBR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, */ +/* LDC, WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS, VECT */ +/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C */ +/* > with */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C */ +/* > with */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': P * C C * P */ +/* > TRANS = 'C': P**H * C C * P**H */ +/* > */ +/* > Here Q and P**H are the unitary matrices determined by CGEBRD when */ +/* > reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q */ +/* > and P**H are defined as products of elementary reflectors H(i) and */ +/* > G(i) respectively. */ +/* > */ +/* > Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */ +/* > order of the unitary matrix Q or P**H that is applied. */ +/* > */ +/* > If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */ +/* > if nq >= k, Q = H(1) H(2) . . . H(k); */ +/* > if nq < k, Q = H(1) H(2) . . . H(nq-1). */ +/* > */ +/* > If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */ +/* > if k < nq, P = G(1) G(2) . . . G(k); */ +/* > if k >= nq, P = G(1) G(2) . . . G(nq-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > = 'Q': apply Q or Q**H; */ +/* > = 'P': apply P or P**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q, Q**H, P or P**H from the Left; */ +/* > = 'R': apply Q, Q**H, P or P**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q or P; */ +/* > = 'C': Conjugate transpose, apply Q**H or P**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > If VECT = 'Q', the number of columns in the original */ +/* > matrix reduced by CGEBRD. */ +/* > If VECT = 'P', the number of rows in the original */ +/* > matrix reduced by CGEBRD. */ +/* > K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,f2cmin(nq,K)) if VECT = 'Q' */ +/* > (LDA,nq) if VECT = 'P' */ +/* > The vectors which define the elementary reflectors H(i) and */ +/* > G(i), whose products determine the matrices Q and P, as */ +/* > returned by CGEBRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If VECT = 'Q', LDA >= f2cmax(1,nq); */ +/* > if VECT = 'P', LDA >= f2cmax(1,f2cmin(nq,K)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (f2cmin(nq,K)) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i) or G(i) which determines Q or P, as returned */ +/* > by CGEBRD in the array argument TAUQ or TAUP. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q */ +/* > or P*C or P**H*C or C*P or C*P**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M); */ +/* > if N = 0 or M = 0, LWORK >= 1. */ +/* > For optimum performance LWORK >= f2cmax(1,N*NB) if SIDE = 'L', */ +/* > and LWORK >= f2cmax(1,M*NB) if SIDE = 'R', where NB is the */ +/* > optimal blocksize. (NB = 0 if M = 0 or N = 0.) */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cunmbr_(char *vect, char *side, char *trans, integer *m, + integer *n, integer *k, complex *a, integer *lda, complex *tau, + complex *c__, integer *ldc, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; + char ch__1[2]; + + /* Local variables */ + logical left; + extern logical lsame_(char *, char *); + integer iinfo, i1, i2, nb, mi, ni, nq, nw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int cunmlq_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *, integer *); + logical notran; + extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *, integer *); + logical applyq; + char transt[1]; + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + applyq = lsame_(vect, "Q"); + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q or P and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (*m == 0 || *n == 0) { + nw = 0; + } + if (! applyq && ! lsame_(vect, "P")) { + *info = -1; + } else if (! left && ! lsame_(side, "R")) { + *info = -2; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*k < 0) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = f2cmin(nq,*k); + if (applyq && *lda < f2cmax(1,nq) || ! applyq && *lda < f2cmax(i__1,i__2)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } else if (*lwork < f2cmax(1,nw) && ! lquery) { + *info = -13; + } + } + + if (*info == 0) { + if (nw > 0) { + if (applyq) { + if (left) { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, "CUNMQR", ch__1, &i__1, n, &i__2, & + c_n1, (ftnlen)6, (ftnlen)2); + } else { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, "CUNMQR", ch__1, m, &i__1, &i__2, & + c_n1, (ftnlen)6, (ftnlen)2); + } + } else { + if (left) { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, "CUNMLQ", ch__1, &i__1, n, &i__2, & + c_n1, (ftnlen)6, (ftnlen)2); + } else { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, "CUNMLQ", ch__1, m, &i__1, &i__2, & + c_n1, (ftnlen)6, (ftnlen)2); + } + } +/* Computing MAX */ + i__1 = 1, i__2 = nw * nb; + lwkopt = f2cmax(i__1,i__2); + } else { + lwkopt = 1; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMBR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + if (applyq) { + +/* Apply Q */ + + if (nq >= *k) { + +/* Q was determined by a call to CGEBRD with nq >= k */ + + cunmqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], lwork, &iinfo); + } else if (nq > 1) { + +/* Q was determined by a call to CGEBRD with nq < k */ + + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + cunmqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] + , &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); + } + } else { + +/* Apply P */ + + if (notran) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } + if (nq > *k) { + +/* P was determined by a call to CGEBRD with nq > k */ + + cunmlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], lwork, &iinfo); + } else if (nq > 1) { + +/* P was determined by a call to CGEBRD with nq <= k */ + + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + cunmlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, + &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & + iinfo); + } + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNMBR */ + +} /* cunmbr_ */ + diff --git a/lapack-netlib/SRC/cunmhr.c b/lapack-netlib/SRC/cunmhr.c new file mode 100644 index 000000000..1589f829c --- /dev/null +++ b/lapack-netlib/SRC/cunmhr.c @@ -0,0 +1,709 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMHR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMHR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, */ +/* LDC, WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMHR overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix of order nq, with nq = m if */ +/* > SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ +/* > IHI-ILO elementary reflectors, as returned by CGEHRD: */ +/* > */ +/* > Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply Q (No transpose) */ +/* > = 'C': apply Q**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > ILO and IHI must have the same values as in the previous call */ +/* > of CGEHRD. Q is equal to the unit matrix except in the */ +/* > submatrix Q(ilo+1:ihi,ilo+1:ihi). */ +/* > If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */ +/* > ILO = 1 and IHI = 0, if M = 0; */ +/* > if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */ +/* > ILO = 1 and IHI = 0, if N = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L' */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The vectors which define the elementary reflectors, as */ +/* > returned by CGEHRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > LDA >= f2cmax(1,M) if SIDE = 'L'; LDA >= f2cmax(1,N) if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension */ +/* > (M-1) if SIDE = 'L' */ +/* > (N-1) if SIDE = 'R' */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEHRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= N*NB if SIDE = 'L', and */ +/* > LWORK >= M*NB if SIDE = 'R', where NB is the optimal */ +/* > blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cunmhr_(char *side, char *trans, integer *m, integer *n, + integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau, + complex *c__, integer *ldc, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2; + char ch__1[2]; + + /* Local variables */ + logical left; + extern logical lsame_(char *, char *); + integer iinfo, i1, i2, nb, mi, nh, ni, nq, nw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *, integer *); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + nh = *ihi - *ilo; + left = lsame_(side, "L"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ilo < 1 || *ilo > f2cmax(1,nq)) { + *info = -5; + } else if (*ihi < f2cmin(*ilo,nq) || *ihi > nq) { + *info = -6; + } else if (*lda < f2cmax(1,nq)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } else if (*lwork < f2cmax(1,nw) && ! lquery) { + *info = -13; + } + + if (*info == 0) { + if (left) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "CUNMQR", ch__1, &nh, n, &nh, &c_n1, (ftnlen) + 6, (ftnlen)2); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "CUNMQR", ch__1, m, &nh, &nh, &c_n1, (ftnlen) + 6, (ftnlen)2); + } + lwkopt = f2cmax(1,nw) * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__2 = -(*info); + xerbla_("CUNMHR", &i__2, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || nh == 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + + if (left) { + mi = nh; + ni = *n; + i1 = *ilo + 1; + i2 = 1; + } else { + mi = *m; + ni = nh; + i1 = 1; + i2 = *ilo + 1; + } + + cunmqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, & + tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); + + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNMHR */ + +} /* cunmhr_ */ + diff --git a/lapack-netlib/SRC/cunml2.c b/lapack-netlib/SRC/cunml2.c new file mode 100644 index 000000000..1845a5545 --- /dev/null +++ b/lapack-netlib/SRC/cunml2.c @@ -0,0 +1,696 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by +cgelqf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNML2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNML2 overwrites the general complex m-by-n matrix C with */ +/* > */ +/* > Q * C if SIDE = 'L' and TRANS = 'N', or */ +/* > */ +/* > Q**H* C if SIDE = 'L' and TRANS = 'C', or */ +/* > */ +/* > C * Q if SIDE = 'R' and TRANS = 'N', or */ +/* > */ +/* > C * Q**H if SIDE = 'R' and TRANS = 'C', */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(k)**H . . . H(2)**H H(1)**H */ +/* > */ +/* > as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left */ +/* > = 'R': apply Q or Q**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply Q (No transpose) */ +/* > = 'C': apply Q**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGELQF in the first k rows of its array argument A. */ +/* > A is modified by the routine but restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGELQF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the m-by-n matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (N) if SIDE = 'L', */ +/* > (M) if SIDE = 'R' */ +/* > \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 cunml2_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + logical left; + complex taui; + integer i__; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *); + extern logical lsame_(char *, char *); + integer i1, i2, i3, ic, jc, mi, ni, nq; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical notran; + complex aii; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNML2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) or H(i)**H is applied to C(i:m,1:n) */ + + mi = *m - i__ + 1; + ic = i__; + } else { + +/* H(i) or H(i)**H is applied to C(1:m,i:n) */ + + ni = *n - i__ + 1; + jc = i__; + } + +/* Apply H(i) or H(i)**H */ + + if (notran) { + r_cnjg(&q__1, &tau[i__]); + taui.r = q__1.r, taui.i = q__1.i; + } else { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } + if (i__ < nq) { + i__3 = nq - i__; + clacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda); + } + i__3 = i__ + i__ * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = i__ + i__ * a_dim1; + a[i__3].r = 1.f, a[i__3].i = 0.f; + clarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic + + jc * c_dim1], ldc, &work[1]); + i__3 = i__ + i__ * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; + if (i__ < nq) { + i__3 = nq - i__; + clacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda); + } +/* L10: */ + } + return 0; + +/* End of CUNML2 */ + +} /* cunml2_ */ + diff --git a/lapack-netlib/SRC/cunmlq.c b/lapack-netlib/SRC/cunmlq.c new file mode 100644 index 000000000..40475c5bd --- /dev/null +++ b/lapack-netlib/SRC/cunmlq.c @@ -0,0 +1,779 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMLQ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMLQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMLQ overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(k)**H . . . H(2)**H H(1)**H */ +/* > */ +/* > as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Conjugate transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGELQF in the first k rows of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGELQF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \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 cunmlq_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[2]; + + /* Local variables */ + logical left; + integer i__; + extern logical lsame_(char *, char *); + integer nbmin, iinfo, i1, i2, i3; + extern /* Subroutine */ int cunml2_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *); + integer ib, ic, jc, nb, mi, ni; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nq, nw; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical notran; + integer ldwork; + char transt[1]; + integer lwkopt; + logical lquery; + integer iwt; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*lwork < f2cmax(1,nw) && ! lquery) { + *info = -12; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + + if (*m == 0 || *n == 0 || *k == 0) { + lwkopt = 1; + } else { +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMLQ", ch__1, m, n, k, &c_n1, + (ftnlen)6, (ftnlen)2); + nb = f2cmin(i__1,i__2); + lwkopt = f2cmax(1,nw) * nb + 4160; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMLQ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + +/* Determine the block size */ + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < nw * nb + 4160) { + nb = (*lwork - 4160) / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMLQ", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = f2cmax(i__1,i__2); + } + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + cunml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + iwt = nw * nb + 1; + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + if (notran) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = f2cmin(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__4 = nq - i__ + 1; + clarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], + lda, &tau[i__], &work[iwt], &c__65); + if (left) { + +/* H or H**H is applied to C(i:m,1:n) */ + + mi = *m - i__ + 1; + ic = i__; + } else { + +/* H or H**H is applied to C(1:m,i:n) */ + + ni = *n - i__ + 1; + jc = i__; + } + +/* Apply H or H**H */ + + clarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ + + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc * + c_dim1], ldc, &work[1], &ldwork); +/* L10: */ + } + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNMLQ */ + +} /* cunmlq_ */ + diff --git a/lapack-netlib/SRC/cunmql.c b/lapack-netlib/SRC/cunmql.c new file mode 100644 index 000000000..3c2eac75e --- /dev/null +++ b/lapack-netlib/SRC/cunmql.c @@ -0,0 +1,767 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMQL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMQL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMQL overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(k) . . . H(2) H(1) */ +/* > */ +/* > as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGEQLF in the last k columns of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQLF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \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 cunmql_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[2]; + + /* Local variables */ + logical left; + integer i__; + extern logical lsame_(char *, char *); + integer nbmin, iinfo, i1, i2, i3; + extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *); + integer ib, nb, mi, ni; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nq, nw; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical notran; + integer ldwork, lwkopt; + logical lquery; + integer iwt; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = f2cmax(1,*n); + } else { + nq = *n; + nw = f2cmax(1,*m); + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,nq)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*lwork < nw && ! lquery) { + *info = -12; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMQL", ch__1, m, n, k, &c_n1, + (ftnlen)6, (ftnlen)2); + nb = f2cmin(i__1,i__2); + lwkopt = nw * nb + 4160; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMQL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Determine the block size */ + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < nw * nb + 4160) { + nb = (*lwork - 4160) / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMQL", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = f2cmax(i__1,i__2); + } + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + cunm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + iwt = nw * nb + 1; + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = f2cmin(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__4 = nq - *k + i__ + ib - 1; + clarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] + , lda, &tau[i__], &work[iwt], &c__65); + if (left) { + +/* H or H**H is applied to C(1:m-k+i+ib-1,1:n) */ + + mi = *m - *k + i__ + ib - 1; + } else { + +/* H or H**H is applied to C(1:m,1:n-k+i+ib-1) */ + + ni = *n - *k + i__ + ib - 1; + } + +/* Apply H or H**H */ + + clarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[ + i__ * a_dim1 + 1], lda, &work[iwt], &c__65, &c__[c_offset] + , ldc, &work[1], &ldwork); +/* L10: */ + } + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNMQL */ + +} /* cunmql_ */ + diff --git a/lapack-netlib/SRC/cunmqr.c b/lapack-netlib/SRC/cunmqr.c new file mode 100644 index 000000000..ea3ab71d8 --- /dev/null +++ b/lapack-netlib/SRC/cunmqr.c @@ -0,0 +1,766 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMQR overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k) */ +/* > */ +/* > as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Conjugate transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGEQRF in the first k columns of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGEQRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \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 cunmqr_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[2]; + + /* Local variables */ + logical left; + integer i__; + extern logical lsame_(char *, char *); + integer nbmin, iinfo, i1, i2, i3; + extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *); + integer ib, ic, jc, nb, mi, ni; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nq, nw; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical notran; + integer ldwork, lwkopt; + logical lquery; + integer iwt; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,nq)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*lwork < f2cmax(1,nw) && ! lquery) { + *info = -12; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMQR", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nb = f2cmin(i__1,i__2); + lwkopt = f2cmax(1,nw) * nb + 4160; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMQR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < nw * nb + 4160) { + nb = (*lwork - 4160) / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMQR", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = f2cmax(i__1,i__2); + } + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + cunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + iwt = nw * nb + 1; + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = f2cmin(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__4 = nq - i__ + 1; + clarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[iwt], &c__65); + if (left) { + +/* H or H**H is applied to C(i:m,1:n) */ + + mi = *m - i__ + 1; + ic = i__; + } else { + +/* H or H**H is applied to C(1:m,i:n) */ + + ni = *n - i__ + 1; + jc = i__; + } + +/* Apply H or H**H */ + + clarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ + i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + + jc * c_dim1], ldc, &work[1], &ldwork); +/* L10: */ + } + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNMQR */ + +} /* cunmqr_ */ + diff --git a/lapack-netlib/SRC/cunmr2.c b/lapack-netlib/SRC/cunmr2.c new file mode 100644 index 000000000..a78423931 --- /dev/null +++ b/lapack-netlib/SRC/cunmr2.c @@ -0,0 +1,688 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by +cgerqf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMR2 overwrites the general complex m-by-n matrix C with */ +/* > */ +/* > Q * C if SIDE = 'L' and TRANS = 'N', or */ +/* > */ +/* > Q**H* C if SIDE = 'L' and TRANS = 'C', or */ +/* > */ +/* > C * Q if SIDE = 'R' and TRANS = 'N', or */ +/* > */ +/* > C * Q**H if SIDE = 'R' and TRANS = 'C', */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(1)**H H(2)**H . . . H(k)**H */ +/* > */ +/* > as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left */ +/* > = 'R': apply Q or Q**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply Q (No transpose) */ +/* > = 'C': apply Q**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGERQF in the last k rows of its array argument A. */ +/* > A is modified by the routine but restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGERQF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the m-by-n matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (N) if SIDE = 'L', */ +/* > (M) if SIDE = 'R' */ +/* > \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 cunmr2_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + logical left; + complex taui; + integer i__; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *); + extern logical lsame_(char *, char *); + integer i1, i2, i3, mi, ni, nq; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical notran; + complex aii; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMR2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) or H(i)**H is applied to C(1:m-k+i,1:n) */ + + mi = *m - *k + i__; + } else { + +/* H(i) or H(i)**H is applied to C(1:m,1:n-k+i) */ + + ni = *n - *k + i__; + } + +/* Apply H(i) or H(i)**H */ + + if (notran) { + r_cnjg(&q__1, &tau[i__]); + taui.r = q__1.r, taui.i = q__1.i; + } else { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } + i__3 = nq - *k + i__ - 1; + clacgv_(&i__3, &a[i__ + a_dim1], lda); + i__3 = i__ + (nq - *k + i__) * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = i__ + (nq - *k + i__) * a_dim1; + a[i__3].r = 1.f, a[i__3].i = 0.f; + clarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &taui, &c__[c_offset], + ldc, &work[1]); + i__3 = i__ + (nq - *k + i__) * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; + i__3 = nq - *k + i__ - 1; + clacgv_(&i__3, &a[i__ + a_dim1], lda); +/* L10: */ + } + return 0; + +/* End of CUNMR2 */ + +} /* cunmr2_ */ + diff --git a/lapack-netlib/SRC/cunmr3.c b/lapack-netlib/SRC/cunmr3.c new file mode 100644 index 000000000..50d488e06 --- /dev/null +++ b/lapack-netlib/SRC/cunmr3.c @@ -0,0 +1,706 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMR3 multiplies a general matrix by the unitary matrix from a RZ factorization determined by +ctzrzf (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMR3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, */ +/* WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, L, LDA, LDC, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMR3 overwrites the general complex m by n matrix C with */ +/* > */ +/* > Q * C if SIDE = 'L' and TRANS = 'N', or */ +/* > */ +/* > Q**H* C if SIDE = 'L' and TRANS = 'C', or */ +/* > */ +/* > C * Q if SIDE = 'R' and TRANS = 'N', or */ +/* > */ +/* > C * Q**H if SIDE = 'R' and TRANS = 'C', */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k) */ +/* > */ +/* > as returned by CTZRZF. Q is of order m if SIDE = 'L' and of order n */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left */ +/* > = 'R': apply Q or Q**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply Q (No transpose) */ +/* > = 'C': apply Q**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of columns of the matrix A containing */ +/* > the meaningful part of the Householder reflectors. */ +/* > If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CTZRZF in the last k rows of its array argument A. */ +/* > A is modified by the routine but restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CTZRZF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the m-by-n matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (N) if SIDE = 'L', */ +/* > (M) if SIDE = 'R' */ +/* > \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 Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cunmr3_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, complex *a, integer *lda, complex *tau, + complex *c__, integer *ldc, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + logical left; + complex taui; + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int clarz_(char *, integer *, integer *, integer * + , complex *, integer *, complex *, complex *, integer *, complex * + ); + integer i1, i2, i3, ja, ic, jc, mi, ni, nq; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { + *info = -6; + } else if (*lda < f2cmax(1,*k)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMR3", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + ja = *m - *l + 1; + jc = 1; + } else { + mi = *m; + ja = *n - *l + 1; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) or H(i)**H is applied to C(i:m,1:n) */ + + mi = *m - i__ + 1; + ic = i__; + } else { + +/* H(i) or H(i)**H is applied to C(1:m,i:n) */ + + ni = *n - i__ + 1; + jc = i__; + } + +/* Apply H(i) or H(i)**H */ + + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + r_cnjg(&q__1, &tau[i__]); + taui.r = q__1.r, taui.i = q__1.i; + } + clarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &taui, &c__[ic + + jc * c_dim1], ldc, &work[1]); + +/* L10: */ + } + + return 0; + +/* End of CUNMR3 */ + +} /* cunmr3_ */ + diff --git a/lapack-netlib/SRC/cunmrq.c b/lapack-netlib/SRC/cunmrq.c new file mode 100644 index 000000000..bb9206d8a --- /dev/null +++ b/lapack-netlib/SRC/cunmrq.c @@ -0,0 +1,773 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMRQ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMRQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMRQ overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(1)**H H(2)**H . . . H(k)**H */ +/* > */ +/* > as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGERQF in the last k rows of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CGERQF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \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 cunmrq_(char *side, char *trans, integer *m, integer *n, + integer *k, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[2]; + + /* Local variables */ + logical left; + integer i__; + extern logical lsame_(char *, char *); + integer nbmin, iinfo, i1, i2, i3; + extern /* Subroutine */ int cunmr2_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *); + integer ib, nb, mi, ni; + extern /* Subroutine */ int clarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, complex *, integer *); + integer nq, nw; + extern /* Subroutine */ int clarft_(char *, char *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical notran; + integer ldwork; + char transt[1]; + integer lwkopt; + logical lquery; + integer iwt; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = f2cmax(1,*n); + } else { + nq = *n; + nw = f2cmax(1,*m); + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*lwork < nw && ! lquery) { + *info = -12; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1, + (ftnlen)6, (ftnlen)2); + nb = f2cmin(i__1,i__2); + lwkopt = nw * nb + 4160; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMRQ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < nw * nb + 4160) { + nb = (*lwork - 4160) / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMRQ", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = f2cmax(i__1,i__2); + } + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + cunmr2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + iwt = nw * nb + 1; + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + if (notran) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = f2cmin(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__4 = nq - *k + i__ + ib - 1; + clarft_("Backward", "Rowwise", &i__4, &ib, &a[i__ + a_dim1], lda, + &tau[i__], &work[iwt], &c__65); + if (left) { + +/* H or H**H is applied to C(1:m-k+i+ib-1,1:n) */ + + mi = *m - *k + i__ + ib - 1; + } else { + +/* H or H**H is applied to C(1:m,1:n-k+i+ib-1) */ + + ni = *n - *k + i__ + ib - 1; + } + +/* Apply H or H**H */ + + clarfb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, &a[ + i__ + a_dim1], lda, &work[iwt], &c__65, &c__[c_offset], + ldc, &work[1], &ldwork); +/* L10: */ + } + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNMRQ */ + +} /* cunmrq_ */ + diff --git a/lapack-netlib/SRC/cunmrz.c b/lapack-netlib/SRC/cunmrz.c new file mode 100644 index 000000000..fa558deaa --- /dev/null +++ b/lapack-netlib/SRC/cunmrz.c @@ -0,0 +1,814 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CUNMRZ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMRZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, L, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMRZ overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product of k */ +/* > elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k) */ +/* > */ +/* > as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Conjugate transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of columns of the matrix A containing */ +/* > the meaningful part of the Householder reflectors. */ +/* > If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CTZRZF in the last k rows of its array argument A. */ +/* > A is modified by the routine but restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CTZRZF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \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 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cunmrz_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, complex *a, integer *lda, complex *tau, + complex *c__, integer *ldc, complex *work, integer *lwork, integer * + info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[2]; + + /* Local variables */ + logical left; + integer i__; + extern logical lsame_(char *, char *); + integer nbmin, iinfo, i1, i2, i3; + extern /* Subroutine */ int cunmr3_(char *, char *, integer *, integer *, + integer *, integer *, complex *, integer *, complex *, complex *, + integer *, complex *, integer *); + integer ib, ic, ja, jc, nb, mi, ni, nq, nw; + extern /* Subroutine */ int clarzb_(char *, char *, char *, char *, + integer *, integer *, integer *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), clarzt_( + char *, char *, integer *, integer *, complex *, integer *, + complex *, complex *, integer *); + logical notran; + integer ldwork; + char transt[1]; + integer lwkopt; + logical lquery; + integer iwt; + + +/* -- 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = f2cmax(1,*n); + } else { + nq = *n; + nw = f2cmax(1,*m); + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { + *info = -6; + } else if (*lda < f2cmax(1,*k)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } else if (*lwork < f2cmax(1,nw) && ! lquery) { + *info = -13; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1, + (ftnlen)6, (ftnlen)2); + nb = f2cmin(i__1,i__2); + lwkopt = nw * nb + 4160; + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUNMRZ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Determine the block size. */ + +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1, (ftnlen) + 6, (ftnlen)2); + nb = f2cmin(i__1,i__2); + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < nw * nb + 4160) { + nb = (*lwork - 4160) / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMRQ", ch__1, m, n, k, &c_n1, ( + ftnlen)6, (ftnlen)2); + nbmin = f2cmax(i__1,i__2); + } + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + cunmr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + iwt = nw * nb + 1; + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + jc = 1; + ja = *m - *l + 1; + } else { + mi = *m; + ic = 1; + ja = *n - *l + 1; + } + + if (notran) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = f2cmin(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + clarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda, + &tau[i__], &work[iwt], &c__65); + + if (left) { + +/* H or H**H is applied to C(i:m,1:n) */ + + mi = *m - i__ + 1; + ic = i__; + } else { + +/* H or H**H is applied to C(1:m,i:n) */ + + ni = *n - i__ + 1; + jc = i__; + } + +/* Apply H or H**H */ + + clarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[ + i__ + ja * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc + * c_dim1], ldc, &work[1], &ldwork); +/* L10: */ + } + + } + + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CUNMRZ */ + +} /* cunmrz_ */ + diff --git a/lapack-netlib/SRC/cunmtr.c b/lapack-netlib/SRC/cunmtr.c new file mode 100644 index 000000000..a9c9e4b08 --- /dev/null +++ b/lapack-netlib/SRC/cunmtr.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 CUNMTR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUNMTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER SIDE, TRANS, UPLO */ +/* INTEGER INFO, LDA, LDC, LWORK, M, N */ +/* COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUNMTR overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix of order nq, with nq = m if */ +/* > SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ +/* > nq-1 elementary reflectors, as returned by CHETRD: */ +/* > */ +/* > if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ +/* > */ +/* > if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A contains elementary reflectors */ +/* > from CHETRD; */ +/* > = 'L': Lower triangle of A contains elementary reflectors */ +/* > from CHETRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Conjugate transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension */ +/* > (LDA,M) if SIDE = 'L' */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The vectors which define the elementary reflectors, as */ +/* > returned by CHETRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > LDA >= f2cmax(1,M) if SIDE = 'L'; LDA >= f2cmax(1,N) if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension */ +/* > (M-1) if SIDE = 'L' */ +/* > (N-1) if SIDE = 'R' */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CHETRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > 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 SIDE = 'L', LWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= N*NB if SIDE = 'L', and */ +/* > LWORK >=M*NB if SIDE = 'R', where NB is the optimal */ +/* > blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cunmtr_(char *side, char *uplo, char *trans, integer *m, + integer *n, complex *a, integer *lda, complex *tau, complex *c__, + integer *ldc, complex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; + char ch__1[2]; + + /* Local variables */ + logical left; + extern logical lsame_(char *, char *); + integer iinfo, i1; + logical upper; + integer i2, nb, mi, ni, nq, nw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int cunmql_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *, integer *), cunmqr_(char *, + char *, integer *, integer *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, integer *, integer *); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "C")) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,nq)) { + *info = -7; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*lwork < f2cmax(1,nw) && ! lquery) { + *info = -12; + } + + if (*info == 0) { + if (upper) { + if (left) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, "CUNMQL", ch__1, &i__2, n, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "CUNMQL", ch__1, m, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } else { + if (left) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, "CUNMQR", ch__1, &i__2, n, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = trans; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "CUNMQR", ch__1, m, &i__2, &i__3, &c_n1, ( + ftnlen)6, (ftnlen)2); + } + } + lwkopt = f2cmax(1,nw) * nb; + work[1].r = (real) lwkopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__2 = -(*info); + xerbla_("CUNMTR", &i__2, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || nq == 1) { + work[1].r = 1.f, work[1].i = 0.f; + return 0; + } + + if (left) { + mi = *m - 1; + ni = *n; + } else { + mi = *m; + ni = *n - 1; + } + + if (upper) { + +/* Q was determined by a call to CHETRD with UPLO = 'U' */ + + i__2 = nq - 1; + cunmql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & + tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo); + } else { + +/* Q was determined by a call to CHETRD with UPLO = 'L' */ + + if (left) { + i1 = 2; + i2 = 1; + } else { + i1 = 1; + i2 = 2; + } + i__2 = nq - 1; + cunmqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & + c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); + } + work[1].r = (real) lwkopt, work[1].i = 0.f; + return 0; + +/* End of CUNMTR */ + +} /* cunmtr_ */ + diff --git a/lapack-netlib/SRC/cupgtr.c b/lapack-netlib/SRC/cupgtr.c new file mode 100644 index 000000000..3fcdd35a8 --- /dev/null +++ b/lapack-netlib/SRC/cupgtr.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 \b CUPGTR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUPGTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDQ, N */ +/* COMPLEX AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUPGTR generates a complex unitary matrix Q which is defined as the */ +/* > product of n-1 elementary reflectors H(i) of order n, as returned by */ +/* > CHPTRD using packed storage: */ +/* > */ +/* > if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ +/* > */ +/* > if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular packed storage used in previous */ +/* > call to CHPTRD; */ +/* > = 'L': Lower triangular packed storage used in previous */ +/* > call to CHPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix Q. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension (N*(N+1)/2) */ +/* > The vectors which define the elementary reflectors, as */ +/* > returned by CHPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (N-1) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CHPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > The N-by-N unitary matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N-1) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int cupgtr_(char *uplo, integer *n, complex *ap, complex * + tau, complex *q, integer *ldq, complex *work, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + integer iinfo; + logical upper; + extern /* Subroutine */ int cung2l_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *), cung2r_( + integer *, integer *, integer *, complex *, integer *, complex *, + complex *, integer *); + integer ij; + 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 arguments */ + + /* Parameter adjustments */ + --ap; + --tau; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldq < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUPGTR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Q was determined by a call to CHPTRD with UPLO = 'U' */ + +/* Unpack the vectors which define the elementary reflectors and */ +/* set the last row and column of Q equal to those of the unit */ +/* matrix */ + + ij = 2; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * q_dim1; + i__4 = ij; + q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i; + ++ij; +/* L10: */ + } + ij += 2; + i__2 = *n + j * q_dim1; + q[i__2].r = 0.f, q[i__2].i = 0.f; +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + *n * q_dim1; + q[i__2].r = 0.f, q[i__2].i = 0.f; +/* L30: */ + } + i__1 = *n + *n * q_dim1; + q[i__1].r = 1.f, q[i__1].i = 0.f; + +/* Generate Q(1:n-1,1:n-1) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + cung2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & + iinfo); + + } else { + +/* Q was determined by a call to CHPTRD with UPLO = 'L'. */ + +/* Unpack the vectors which define the elementary reflectors and */ +/* set the first row and column of Q equal to those of the unit */ +/* matrix */ + + i__1 = q_dim1 + 1; + q[i__1].r = 1.f, q[i__1].i = 0.f; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + q_dim1; + q[i__2].r = 0.f, q[i__2].i = 0.f; +/* L40: */ + } + ij = 3; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j * q_dim1 + 1; + q[i__2].r = 0.f, q[i__2].i = 0.f; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * q_dim1; + i__4 = ij; + q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i; + ++ij; +/* L50: */ + } + ij += 2; +/* L60: */ + } + if (*n > 1) { + +/* Generate Q(2:n,2:n) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + cung2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], + &work[1], &iinfo); + } + } + return 0; + +/* End of CUPGTR */ + +} /* cupgtr_ */ + diff --git a/lapack-netlib/SRC/cupmtr.c b/lapack-netlib/SRC/cupmtr.c new file mode 100644 index 000000000..e8de7b58e --- /dev/null +++ b/lapack-netlib/SRC/cupmtr.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 CUPMTR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CUPMTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, */ +/* INFO ) */ + +/* CHARACTER SIDE, TRANS, UPLO */ +/* INTEGER INFO, LDC, M, N */ +/* COMPLEX AP( * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CUPMTR overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix of order nq, with nq = m if */ +/* > SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ +/* > nq-1 elementary reflectors, as returned by CHPTRD using packed */ +/* > storage: */ +/* > */ +/* > if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ +/* > */ +/* > if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular packed storage used in previous */ +/* > call to CHPTRD; */ +/* > = 'L': Lower triangular packed storage used in previous */ +/* > call to CHPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Conjugate transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX array, dimension */ +/* > (M*(M+1)/2) if SIDE = 'L' */ +/* > (N*(N+1)/2) if SIDE = 'R' */ +/* > The vectors which define the elementary reflectors, as */ +/* > returned by CHPTRD. AP is modified by the routine but */ +/* > restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (M-1) if SIDE = 'L' */ +/* > or (N-1) if SIDE = 'R' */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by CHPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > (M) if SIDE = 'R' */ +/* > \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 cupmtr_(char *side, char *uplo, char *trans, integer *m, + integer *n, complex *ap, complex *tau, complex *c__, integer *ldc, + complex *work, integer *info) +{ + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + logical left; + complex taui; + integer i__; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *); + extern logical lsame_(char *, char *); + integer i1; + logical upper; + integer i2, i3, ic, jc, ii, mi, ni, nq; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, forwrd; + complex aii; + + +/* -- 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 */ + --ap; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + upper = lsame_(uplo, "U"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! notran && ! lsame_(trans, "C")) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*ldc < f2cmax(1,*m)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CUPMTR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + if (upper) { + +/* Q was determined by a call to CHPTRD with UPLO = 'U' */ + + forwrd = left && notran || ! left && ! notran; + + if (forwrd) { + i1 = 1; + i2 = nq - 1; + i3 = 1; + ii = 2; + } else { + i1 = nq - 1; + i2 = 1; + i3 = -1; + ii = nq * (nq + 1) / 2 - 1; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) or H(i)**H is applied to C(1:i,1:n) */ + + mi = i__; + } else { + +/* H(i) or H(i)**H is applied to C(1:m,1:i) */ + + ni = i__; + } + +/* Apply H(i) or H(i)**H */ + + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + r_cnjg(&q__1, &tau[i__]); + taui.r = q__1.r, taui.i = q__1.i; + } + i__3 = ii; + aii.r = ap[i__3].r, aii.i = ap[i__3].i; + i__3 = ii; + ap[i__3].r = 1.f, ap[i__3].i = 0.f; + clarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &taui, &c__[ + c_offset], ldc, &work[1]); + i__3 = ii; + ap[i__3].r = aii.r, ap[i__3].i = aii.i; + + if (forwrd) { + ii = ii + i__ + 2; + } else { + ii = ii - i__ - 1; + } +/* L10: */ + } + } else { + +/* Q was determined by a call to CHPTRD with UPLO = 'L'. */ + + forwrd = left && ! notran || ! left && notran; + + if (forwrd) { + i1 = 1; + i2 = nq - 1; + i3 = 1; + ii = 2; + } else { + i1 = nq - 1; + i2 = 1; + i3 = -1; + ii = nq * (nq + 1) / 2 - 1; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__2 = i2; + i__1 = i3; + for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + i__3 = ii; + aii.r = ap[i__3].r, aii.i = ap[i__3].i; + i__3 = ii; + ap[i__3].r = 1.f, ap[i__3].i = 0.f; + if (left) { + +/* H(i) or H(i)**H is applied to C(i+1:m,1:n) */ + + mi = *m - i__; + ic = i__ + 1; + } else { + +/* H(i) or H(i)**H is applied to C(1:m,i+1:n) */ + + ni = *n - i__; + jc = i__ + 1; + } + +/* Apply H(i) or H(i)**H */ + + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + r_cnjg(&q__1, &tau[i__]); + taui.r = q__1.r, taui.i = q__1.i; + } + clarf_(side, &mi, &ni, &ap[ii], &c__1, &taui, &c__[ic + jc * + c_dim1], ldc, &work[1]); + i__3 = ii; + ap[i__3].r = aii.r, ap[i__3].i = aii.i; + + if (forwrd) { + ii = ii + nq - i__ + 1; + } else { + ii = ii - nq + i__ - 2; + } +/* L20: */ + } + } + return 0; + +/* End of CUPMTR */ + +} /* cupmtr_ */ +