diff --git a/lapack-netlib/INSTALL/droundup_lwork.c b/lapack-netlib/INSTALL/droundup_lwork.c index 6d1f39a126..0c69e63503 100644 --- a/lapack-netlib/INSTALL/droundup_lwork.c +++ b/lapack-netlib/INSTALL/droundup_lwork.c @@ -1,38 +1,36 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include #include -#include -#ifdef complex -#undef complex +#include + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; #endif -#ifdef I -#undef I + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) #endif -typedef int integer; +typedef blasint integer; + typedef unsigned int uinteger; typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) typedef int logical; typedef short int shortlogical; typedef char logical1; @@ -46,195 +44,74 @@ typedef char integer1; #define Extern extern #endif -/* I/O stuff */ - -typedef int flag; -typedef int ftnlen; -typedef int ftnint; - -/*external read, write*/ -typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; -} cilist; - -/*internal read, write*/ -typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; -} icilist; - -/*open*/ -typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; -} olist; - -/*close*/ -typedef struct -{ flag cerr; - ftnint cunit; - char *csta; -} cllist; - -/*rewind, backspace, endfile*/ -typedef struct -{ flag aerr; - ftnint aunit; -} alist; - -/* inquire */ -typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; /*parameters in standard's order*/ - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; -} inlist; - -#define VOID void - -union Multitype { /* for multiple entry points */ - integer1 g; - shortint h; - integer i; - /* longint j; */ - real r; - doublereal d; - complex c; - doublecomplex z; - }; - -typedef union Multitype Multitype; - -struct Vardesc { /* for Namelist */ - char *name; - char *addr; - ftnlen *dims; - int type; - }; -typedef struct Vardesc Vardesc; - -struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; -typedef struct Namelist Namelist; - -#define abs(x) ((x) >= 0 ? (x) : -(x)) -#define dabs(x) (fabs(x)) -#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) -#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) -#define dmin(a,b) (f2cmin(a,b)) -#define dmax(a,b) (f2cmax(a,b)) -#define bit_test(a,b) ((a) >> (b) & 1) -#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) -#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) - -#define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} -#define d_abs(x) (fabs(*(x))) -#define d_acos(x) (acos(*(x))) -#define d_asin(x) (asin(*(x))) -#define d_atan(x) (atan(*(x))) -#define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } -#define d_cos(x) (cos(*(x))) -#define d_cosh(x) (cosh(*(x))) -#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) -#define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) -#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) -#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) -#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) -#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) -#define d_log(x) (log(*(x))) -#define d_mod(x, y) (fmod(*(x), *(y))) -#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) -#define d_nint(x) u_nint(*(x)) -#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) -#define d_sign(a,b) u_sign(*(a),*(b)) -#define r_sign(a,b) u_sign(*(a),*(b)) -#define d_sin(x) (sin(*(x))) -#define d_sinh(x) (sinh(*(x))) -#define d_sqrt(x) (sqrt(*(x))) -#define d_tan(x) (tan(*(x))) -#define d_tanh(x) (tanh(*(x))) -#define i_abs(x) abs(*(x)) -#define i_dnnt(x) ((integer)u_nint(*(x))) -#define i_len(s, n) (n) -#define i_nint(x) ((integer)u_nint(*(x))) -#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) -#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) -#define pow_si(B,E) spow_ui(*(B),*(E)) -#define pow_ri(B,E) spow_ui(*(B),*(E)) -#define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} -#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } -#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) -#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } -#define sig_die(s, kill) { exit(1); } -#define s_stop(s, n) {exit(0);} -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} -#define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL -//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) - -/* procedure parameter types for -A and -C++ */ - -#define F2C_proc_par_types 1 +/* INTEGER LWORK */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DROUNDUP_LWORK deals with a subtle bug with returning LWORK as a Float. */ +/* > This routine guarantees it is rounded up instead of down by */ +/* > multiplying LWORK by 1+eps when it is necessary, where eps is the relative machine precision. */ +/* > E.g., */ +/* > */ +/* > float( 9007199254740993 ) == 9007199254740992 */ +/* > float( 9007199254740993 ) * (1.+eps) == 9007199254740994 */ +/* > */ +/* > \return DROUNDUP_LWORK */ +/* > \verbatim */ +/* > DROUNDUP_LWORK >= LWORK. */ +/* > DROUNDUP_LWORK is guaranteed to have zero decimal part. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] LWORK Workspace size. */ + +/* Authors: */ +/* ======== */ + +/* > \author Weslley Pereira, University of Colorado Denver, USA */ + +/* > \ingroup auxOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > This routine was inspired in the method `magma_zmake_lwork` from MAGMA. */ +/* > \see https://bitbucket.org/icl/magma/src/master/control/magma_zauxiliary.cpp */ +/* > \endverbatim */ + +/* ===================================================================== */ +double droundup_lwork__(integer *lwork) +{ + /* System generated locals */ + double ret_val; + + /* Local variables */ + double epsilon=DBL_EPSILON; + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + ret_val = (double) (*lwork); + + if ((integer) ret_val < *lwork) { +/* Force round up of LWORK */ + ret_val *= epsilon + 1.f; + } + + return ret_val; + +/* End of DROUNDUP_LWORK */ + +} /* sroundup_lwork__ */ -#endif diff --git a/lapack-netlib/INSTALL/sroundup_lwork.c b/lapack-netlib/INSTALL/sroundup_lwork.c index 6d1f39a126..5c02c4c72f 100644 --- a/lapack-netlib/INSTALL/sroundup_lwork.c +++ b/lapack-netlib/INSTALL/sroundup_lwork.c @@ -1,38 +1,36 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include #include -#include -#ifdef complex -#undef complex +#include + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; #endif -#ifdef I -#undef I + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) #endif -typedef int integer; +typedef blasint integer; + typedef unsigned int uinteger; typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) typedef int logical; typedef short int shortlogical; typedef char logical1; @@ -46,195 +44,74 @@ typedef char integer1; #define Extern extern #endif -/* I/O stuff */ - -typedef int flag; -typedef int ftnlen; -typedef int ftnint; - -/*external read, write*/ -typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; -} cilist; - -/*internal read, write*/ -typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; -} icilist; - -/*open*/ -typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; -} olist; - -/*close*/ -typedef struct -{ flag cerr; - ftnint cunit; - char *csta; -} cllist; - -/*rewind, backspace, endfile*/ -typedef struct -{ flag aerr; - ftnint aunit; -} alist; - -/* inquire */ -typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; /*parameters in standard's order*/ - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; -} inlist; - -#define VOID void - -union Multitype { /* for multiple entry points */ - integer1 g; - shortint h; - integer i; - /* longint j; */ - real r; - doublereal d; - complex c; - doublecomplex z; - }; - -typedef union Multitype Multitype; - -struct Vardesc { /* for Namelist */ - char *name; - char *addr; - ftnlen *dims; - int type; - }; -typedef struct Vardesc Vardesc; - -struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; -typedef struct Namelist Namelist; - -#define abs(x) ((x) >= 0 ? (x) : -(x)) -#define dabs(x) (fabs(x)) -#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) -#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) -#define dmin(a,b) (f2cmin(a,b)) -#define dmax(a,b) (f2cmax(a,b)) -#define bit_test(a,b) ((a) >> (b) & 1) -#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) -#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) - -#define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} -#define d_abs(x) (fabs(*(x))) -#define d_acos(x) (acos(*(x))) -#define d_asin(x) (asin(*(x))) -#define d_atan(x) (atan(*(x))) -#define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } -#define d_cos(x) (cos(*(x))) -#define d_cosh(x) (cosh(*(x))) -#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) -#define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) -#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) -#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) -#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) -#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) -#define d_log(x) (log(*(x))) -#define d_mod(x, y) (fmod(*(x), *(y))) -#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) -#define d_nint(x) u_nint(*(x)) -#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) -#define d_sign(a,b) u_sign(*(a),*(b)) -#define r_sign(a,b) u_sign(*(a),*(b)) -#define d_sin(x) (sin(*(x))) -#define d_sinh(x) (sinh(*(x))) -#define d_sqrt(x) (sqrt(*(x))) -#define d_tan(x) (tan(*(x))) -#define d_tanh(x) (tanh(*(x))) -#define i_abs(x) abs(*(x)) -#define i_dnnt(x) ((integer)u_nint(*(x))) -#define i_len(s, n) (n) -#define i_nint(x) ((integer)u_nint(*(x))) -#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) -#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) -#define pow_si(B,E) spow_ui(*(B),*(E)) -#define pow_ri(B,E) spow_ui(*(B),*(E)) -#define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} -#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } -#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) -#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } -#define sig_die(s, kill) { exit(1); } -#define s_stop(s, n) {exit(0);} -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} -#define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL -//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) - -/* procedure parameter types for -A and -C++ */ - -#define F2C_proc_par_types 1 +/* INTEGER LWORK */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SROUNDUP_LWORK deals with a subtle bug with returning LWORK as a Float. */ +/* > This routine guarantees it is rounded up instead of down by */ +/* > multiplying LWORK by 1+eps when it is necessary, where eps is the relative machine precision. */ +/* > E.g., */ +/* > */ +/* > float( 16777217 ) == 16777216 */ +/* > float( 16777217 ) * (1.+eps) == 16777218 */ +/* > */ +/* > \return SROUNDUP_LWORK */ +/* > \verbatim */ +/* > SROUNDUP_LWORK >= LWORK. */ +/* > SROUNDUP_LWORK is guaranteed to have zero decimal part. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] LWORK Workspace size. */ + +/* Authors: */ +/* ======== */ + +/* > \author Weslley Pereira, University of Colorado Denver, USA */ + +/* > \ingroup auxOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > This routine was inspired in the method `magma_zmake_lwork` from MAGMA. */ +/* > \see https://bitbucket.org/icl/magma/src/master/control/magma_zauxiliary.cpp */ +/* > \endverbatim */ + +/* ===================================================================== */ +real sroundup_lwork__(integer *lwork) +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + real epsilon=FLT_EPSILON; + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + ret_val = (real) (*lwork); + + if ((integer) ret_val < *lwork) { +/* Force round up of LWORK */ + ret_val *= epsilon + 1.f; + } + + return ret_val; + +/* End of SROUNDUP_LWORK */ + +} /* sroundup_lwork__ */ -#endif diff --git a/lapack-netlib/SRC/claqz0.c b/lapack-netlib/SRC/claqz0.c index 6d7e7d5340..d8c8eb10bb 100644 --- a/lapack-netlib/SRC/claqz0.c +++ b/lapack-netlib/SRC/claqz0.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -18,6 +9,7 @@ #ifdef I #undef I #endif + #if defined(_WIN64) typedef long long BLASLONG; typedef unsigned long long BLASULONG; @@ -47,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -190,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -203,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -243,26 +247,25 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -287,6 +290,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -299,6 +317,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -311,6 +345,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -344,6 +379,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *n || *ihi < *ilo - 1) { + *info = -6; + } else if (*lda < *n) { + *info = -8; + } else if (*ldb < *n) { + *info = -10; + } else if (*ldq < 1 || (ilq && *ldq < *n)) { + *info = -15; + } else if (*ldz < 1 || (ilz && *ldz < *n)) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAQZ0", &i__1); + return; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1].r = 1.f, work[1].i = 0.f; + return; + } + +/* Get the parameters */ + + *(unsigned char *)jbcmpz = *(unsigned char *)wants; + *(unsigned char *)&jbcmpz[1] = *(unsigned char *)wantq; + *(unsigned char *)&jbcmpz[2] = *(unsigned char *)wantz; + nmin = ilaenv_(&c__12, "CLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = ilaenv_(&c__13, "CLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + nibble = ilaenv_(&c__14, "CLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)3); + nsr = ilaenv_(&c__15, "CLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - * + ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + rcost = ilaenv_(&c__17, "CLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + itemp1 = (integer) ((real) nsr / sqrt((real) nsr * 2 / ((real) rcost / + 100 * (real) (*n)) + 1)); + itemp1 = ((itemp1 - 1) / 4 << 2) + 4; + nbr = nsr + itemp1; + if (*n < nmin || *rec >= 2) { + chgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alpha[1], &beta[1], &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], lwork, &rwork[1], info); + return; + } + +/* Find out required workspace */ + +/* Workspace query to CLAQZ2 */ + nw = f2cmax(nwr,nmin); + claqz2_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nw, &a[a_offset], lda, &b[ + b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + n_undeflated__, &n_deflated__, &alpha[1], &beta[1], &work[1], &nw, + &work[1], &nw, &work[1], &c_n1, &rwork[1], rec, &aed_info__); + itemp1 = (integer) work[1].r; +/* Workspace query to CLAQZ3 */ + claqz3_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nsr, &nbr, &alpha[1], &beta[1] + , &a[a_offset], lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], &nbr, &work[1], &nbr, &work[1], &c_n1, & + sweep_info__); + itemp2 = (integer) work[1].r; +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__4 = nbr; + i__1 = itemp1 + (i__3 * i__3 << 1), i__2 = itemp2 + (i__4 * i__4 << 1); + lworkreq = f2cmax(i__1,i__2); + if (*lwork == -1) { + r__1 = (real) lworkreq; + work[1].r = r__1, work[1].i = 0.f; + return; + } else if (*lwork < lworkreq) { + *info = -18; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAQZ0", &i__1); + return; + } + +/* Initialize Q and Z */ + + if (iwantq == 3) { + claset_("FULL", n, n, &c_b1, &c_b2, &q[q_offset], ldq); + } + if (iwantz == 3) { + claset_("FULL", n, n, &c_b1, &c_b2, &z__[z_offset], ldz); + } +/* Get machine constants */ + safmin = slamch_("SAFE MINIMUM"); + safmax = 1.f / safmin; + ulp = slamch_("PRECISION"); + smlnum = safmin * ((real) (*n) / ulp); + i__1 = *ihi - *ilo + 1; + bnorm = clanhs_("F", &i__1, &b[*ilo + *ilo * b_dim1], ldb, &rwork[1]); +/* Computing MAX */ + r__1 = safmin, r__2 = ulp * bnorm; + btol = f2cmax(r__1,r__2); + istart = *ilo; + istop = *ihi; + maxit = (*ihi - *ilo + 1) * 30; + ld = 0; + i__1 = maxit; + for (iiter = 1; iiter <= i__1; ++iiter) { + if (iiter >= maxit) { + *info = istop + 1; + goto L80; + } + if (istart + 1 >= istop) { + istop = istart; + myexit_(); + } +/* Check deflations at the end */ +/* Computing MAX */ + r__1 = smlnum, r__2 = ulp * (c_abs(&a[istop + istop * a_dim1]) + + c_abs(&a[istop - 1 + (istop - 1) * a_dim1])); + if (c_abs(&a[istop + (istop - 1) * a_dim1]) <= f2cmax(r__1,r__2)) { + i__2 = istop + (istop - 1) * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; + --istop; + ld = 0; + eshift.r = 0.f, eshift.i = 0.f; + } +/* Check deflations at the start */ +/* Computing MAX */ + r__1 = smlnum, r__2 = ulp * (c_abs(&a[istart + istart * a_dim1]) + + c_abs(&a[istart + 1 + (istart + 1) * a_dim1])); + if (c_abs(&a[istart + 1 + istart * a_dim1]) <= f2cmax(r__1,r__2)) { + i__2 = istart + 1 + istart * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; + ++istart; + ld = 0; + eshift.r = 0.f, eshift.i = 0.f; + } + if (istart + 1 >= istop) { + myexit_(); + } +/* Check interior deflations */ + istart2 = istart; + i__2 = istart + 1; + for (k = istop; k >= i__2; --k) { +/* Computing MAX */ + r__1 = smlnum, r__2 = ulp * (c_abs(&a[k + k * a_dim1]) + c_abs(&a[ + k - 1 + (k - 1) * a_dim1])); + if (c_abs(&a[k + (k - 1) * a_dim1]) <= f2cmax(r__1,r__2)) { + i__3 = k + (k - 1) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + istart2 = k; + myexit_(); + } + } +/* Get range to apply rotations to */ + if (ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = istart2; + istopm = istop; + } +/* Check infinite eigenvalues, this is done without blocking so might */ +/* slow down the method when many infinite eigenvalues are present */ + k = istop; + while(k >= istart2) { + if (c_abs(&b[k + k * b_dim1]) < btol) { +/* A diagonal element of B is negligible, move it */ +/* to the top and deflate it */ + i__2 = istart2 + 1; + for (k2 = k; k2 >= i__2; --k2) { + clartg_(&b[k2 - 1 + k2 * b_dim1], &b[k2 - 1 + (k2 - 1) * + b_dim1], &c1, &s1, &temp); + i__3 = k2 - 1 + k2 * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; + i__3 = k2 - 1 + (k2 - 1) * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; + i__3 = k2 - 2 - istartm + 1; + crot_(&i__3, &b[istartm + k2 * b_dim1], &c__1, &b[istartm + + (k2 - 1) * b_dim1], &c__1, &c1, &s1); +/* Computing MIN */ + i__4 = k2 + 1; + i__3 = f2cmin(i__4,istop) - istartm + 1; + crot_(&i__3, &a[istartm + k2 * a_dim1], &c__1, &a[istartm + + (k2 - 1) * a_dim1], &c__1, &c1, &s1); + if (ilz) { + crot_(n, &z__[k2 * z_dim1 + 1], &c__1, &z__[(k2 - 1) * + z_dim1 + 1], &c__1, &c1, &s1); + } + if (k2 < istop) { + clartg_(&a[k2 + (k2 - 1) * a_dim1], &a[k2 + 1 + (k2 - + 1) * a_dim1], &c1, &s1, &temp); + i__3 = k2 + (k2 - 1) * a_dim1; + a[i__3].r = temp.r, a[i__3].i = temp.i; + i__3 = k2 + 1 + (k2 - 1) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + i__3 = istopm - k2 + 1; + crot_(&i__3, &a[k2 + k2 * a_dim1], lda, &a[k2 + 1 + + k2 * a_dim1], lda, &c1, &s1); + i__3 = istopm - k2 + 1; + crot_(&i__3, &b[k2 + k2 * b_dim1], ldb, &b[k2 + 1 + + k2 * b_dim1], ldb, &c1, &s1); + if (ilq) { + r_cnjg(&q__1, &s1); + crot_(n, &q[k2 * q_dim1 + 1], &c__1, &q[(k2 + 1) * + q_dim1 + 1], &c__1, &c1, &q__1); + } + } + } + if (istart2 < istop) { + clartg_(&a[istart2 + istart2 * a_dim1], &a[istart2 + 1 + + istart2 * a_dim1], &c1, &s1, &temp); + i__2 = istart2 + istart2 * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + i__2 = istart2 + 1 + istart2 * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; + i__2 = istopm - (istart2 + 1) + 1; + crot_(&i__2, &a[istart2 + (istart2 + 1) * a_dim1], lda, & + a[istart2 + 1 + (istart2 + 1) * a_dim1], lda, &c1, + &s1); + i__2 = istopm - (istart2 + 1) + 1; + crot_(&i__2, &b[istart2 + (istart2 + 1) * b_dim1], ldb, & + b[istart2 + 1 + (istart2 + 1) * b_dim1], ldb, &c1, + &s1); + if (ilq) { + r_cnjg(&q__1, &s1); + crot_(n, &q[istart2 * q_dim1 + 1], &c__1, &q[(istart2 + + 1) * q_dim1 + 1], &c__1, &c1, &q__1); + } + } + ++istart2; + } + --k; + } +/* istart2 now points to the top of the bottom right */ +/* unreduced Hessenberg block */ + if (istart2 >= istop) { + istop = istart2 - 1; + ld = 0; + eshift.r = 0.f, eshift.i = 0.f; + mycycle_(); + } + nw = nwr; + nshifts = nsr; + nblock = nbr; + if (istop - istart2 + 1 < nmin) { +/* Setting nw to the size of the subblock will make AED deflate */ +/* all the eigenvalues. This is slightly more efficient than just */ +/* using CHGEQZ because the off diagonal part gets updated via BLAS. */ + if (istop - istart + 1 < nmin) { + nw = istop - istart + 1; + istart2 = istart; + } else { + nw = istop - istart2 + 1; + } + } + +/* Time for AED */ + +/* Computing 2nd power */ + i__2 = nw; +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__5 = nw; + i__4 = *lwork - (i__5 * i__5 << 1); + claqz2_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &nw, &a[a_offset], + lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], + ldz, &n_undeflated__, &n_deflated__, &alpha[1], &beta[1], & + work[1], &nw, &work[i__2 * i__2 + 1], &nw, &work[(i__3 * i__3 + << 1) + 1], &i__4, &rwork[1], rec, &aed_info__); + if (n_deflated__ > 0) { + istop -= n_deflated__; + ld = 0; + eshift.r = 0.f, eshift.i = 0.f; + } + if (n_deflated__ * 100 > nibble * (n_deflated__ + n_undeflated__) || + istop - istart2 + 1 < nmin) { +/* AED has uncovered many eigenvalues. Skip a QZ sweep and run */ +/* AED again. */ + mycycle_(); + } + ++ld; +/* Computing MIN */ + i__2 = nshifts, i__3 = istop - istart2; + ns = f2cmin(i__2,i__3); + ns = f2cmin(ns,n_undeflated__); + shiftpos = istop - n_undeflated__ + 1; + if (ld % 6 == 0) { + +/* Exceptional shift. Chosen for no particularly good reason. */ + + if ((real) maxit * safmin * c_abs(&a[istop + (istop - 1) * a_dim1] + ) < c_abs(&a[istop - 1 + (istop - 1) * a_dim1])) { + c_div(&q__1, &a[istop + (istop - 1) * a_dim1], &b[istop - 1 + + (istop - 1) * b_dim1]); + eshift.r = q__1.r, eshift.i = q__1.i; + } else { + r__1 = safmin * (real) maxit; + q__2.r = 1.f / r__1, q__2.i = 0.f / r__1; + q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i; + eshift.r = q__1.r, eshift.i = q__1.i; + } + i__2 = shiftpos; + alpha[i__2].r = 1.f, alpha[i__2].i = 0.f; + i__2 = shiftpos; + beta[i__2].r = eshift.r, beta[i__2].i = eshift.i; + ns = 1; + } + +/* Time for a QZ sweep */ + +/* Computing 2nd power */ + i__2 = nblock; +/* Computing 2nd power */ + i__3 = nblock; +/* Computing 2nd power */ + i__5 = nblock; + i__4 = *lwork - (i__5 * i__5 << 1); + claqz3_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &ns, &nblock, & + alpha[shiftpos], &beta[shiftpos], &a[a_offset], lda, &b[ + b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &work[ + 1], &nblock, &work[i__2 * i__2 + 1], &nblock, &work[(i__3 * + i__3 << 1) + 1], &i__4, &sweep_info__); + } + +/* Call CHGEQZ to normalize the eigenvalue blocks and set the eigenvalues */ +/* If all the eigenvalues have been found, CHGEQZ will not do any iterations */ +/* and only normalize the blocks. In case of a rare convergence failure, */ +/* the single shift might perform better. */ + +L80: + chgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], + ldb, &alpha[1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldz, + &work[1], lwork, &rwork[1], &norm_info__); + *info = norm_info__; + return; +} /* claqz0_ */ + diff --git a/lapack-netlib/SRC/claqz1.c b/lapack-netlib/SRC/claqz1.c index 7856e080ff..9c7568db61 100644 --- a/lapack-netlib/SRC/claqz1.c +++ b/lapack-netlib/SRC/claqz1.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -191,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -204,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -244,26 +247,25 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +290,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +317,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +345,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +379,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i #include #include @@ -48,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -191,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -204,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -244,159 +247,392 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; + + +/* -- translated by f2c (version 20200916). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + + + +/* Table of constant values */ + +static complex c_b1 = {0.f,0.f}; +static complex c_b2 = {1.f,0.f}; +static integer c__1 = 1; +static integer c_n1 = -1; +static logical c_true = TRUE_; + +/* Subroutine */ void claqz2_(logical *ilschur, logical *ilq, logical *ilz, + integer *n, integer *ilo, integer *ihi, integer *nw, complex *a, + integer *lda, complex *b, integer *ldb, complex *q, integer *ldq, + complex *z__, integer *ldz, integer *ns, integer *nd, complex *alpha, + complex *beta, complex *qc, integer *ldqc, complex *zc, integer *ldzc, + complex *work, integer *lwork, real *rwork, integer *rec, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, qc_dim1, qc_offset, zc_dim1, zc_offset, i__1, i__2, + i__3, i__4; + real r__1, r__2; + complex q__1, q__2; + + /* Local variables */ + integer lworkreq, k; + complex s; + real c1; + integer k2; + complex s1; + integer jw, imk; + real ulp; + integer ctgexc_info__, ifst; + complex temp; + extern /* Subroutine */ void crot_(integer *, complex *, integer *, + complex *, integer *, real *, complex *); + integer ilst; + extern /* Subroutine */ void cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + integer kwbot; + real tempr; + complex mktmp; + integer kwtop; + extern /* Subroutine */ void claqz0_(char *, char *, char *, integer *, + integer *, integer *, complex *, integer *, complex *, integer *, + complex *, complex *, complex *, integer *, complex *, integer *, + complex *, integer *, real *, integer *, integer *); + integer qz_small_info__; + extern /* Subroutine */ void claqz1_(logical *, logical *, integer *, + integer *, integer *, integer *, complex *, integer *, complex *, + integer *, integer *, integer *, complex *, integer *, integer *, + integer *, complex *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ void clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), claset_(char *, + integer *, integer *, complex *, complex *, complex *, integer *); + real safmin; + extern /* Subroutine */ void xerbla_(char *, integer *); + real safmax; + extern /* Subroutine */ void ctgexc_(logical *, logical *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, integer *, integer *, integer *), clartg_( + complex *, complex *, real *, complex *, complex *); + integer istopm; + real smlnum; + integer istartm; + +/* Arguments */ +/* Parameters */ +/* Local Scalars */ +/* External Functions */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --alpha; + --beta; + qc_dim1 = *ldqc; + qc_offset = 1 + qc_dim1; + qc -= qc_offset; + zc_dim1 = *ldzc; + zc_offset = 1 + zc_dim1; + zc -= zc_offset; + --work; + --rwork; + + /* Function Body */ + *info = 0; +/* Set up deflation window */ +/* Computing MIN */ + i__1 = *nw, i__2 = *ihi - *ilo + 1; + jw = f2cmin(i__1,i__2); + kwtop = *ihi - jw + 1; + if (kwtop == *ilo) { + s.r = 0.f, s.i = 0.f; + } else { + i__1 = kwtop + (kwtop - 1) * a_dim1; + s.r = a[i__1].r, s.i = a[i__1].i; + } +/* Determine required workspace */ + ifst = 1; + ilst = jw; + i__1 = *rec + 1; + claqz0_("S", "V", "V", &jw, &c__1, &jw, &a[kwtop + kwtop * a_dim1], lda, & + b[kwtop + kwtop * b_dim1], ldb, &alpha[1], &beta[1], &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &work[1], &c_n1, &rwork[1] + , &i__1, &qz_small_info__); +/* Computing 2nd power */ + i__1 = jw; + lworkreq = (integer) work[1].r + (i__1 * i__1 << 1); +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *nw; + i__1 = lworkreq, i__2 = *n * *nw, i__1 = f2cmax(i__1,i__2), i__2 = (i__3 * + i__3 << 1) + *n; + lworkreq = f2cmax(i__1,i__2); + if (*lwork == -1) { +/* workspace query, quick return */ + q__1.r = (real) lworkreq, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return; + } else if (*lwork < lworkreq) { + *info = -25; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAQZ2", &i__1); + return; + } +/* Get machine constants */ + safmin = slamch_("SAFE MINIMUM"); + safmax = 1.f / safmin; + ulp = slamch_("PRECISION"); + smlnum = safmin * ((real) (*n) / ulp); + if (*ihi == kwtop) { +/* 1 by 1 deflation window, just try a regular deflation */ + i__1 = kwtop; + i__2 = kwtop + kwtop * a_dim1; + alpha[i__1].r = a[i__2].r, alpha[i__1].i = a[i__2].i; + i__1 = kwtop; + i__2 = kwtop + kwtop * b_dim1; + beta[i__1].r = b[i__2].r, beta[i__1].i = b[i__2].i; + *ns = 1; + *nd = 0; +/* Computing MAX */ + r__1 = smlnum, r__2 = ulp * c_abs(&a[kwtop + kwtop * a_dim1]); + if (c_abs(&s) <= f2cmax(r__1,r__2)) { + *ns = 0; + *nd = 1; + if (kwtop > *ilo) { + i__1 = kwtop + (kwtop - 1) * a_dim1; + a[i__1].r = 0.f, a[i__1].i = 0.f; + } } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } + } +/* Store window in case of convergence failure */ + clacpy_("ALL", &jw, &jw, &a[kwtop + kwtop * a_dim1], lda, &work[1], &jw); +/* Computing 2nd power */ + i__1 = jw; + clacpy_("ALL", &jw, &jw, &b[kwtop + kwtop * b_dim1], ldb, &work[i__1 * + i__1 + 1], &jw); +/* Transform window to real schur form */ + claset_("FULL", &jw, &jw, &c_b1, &c_b2, &qc[qc_offset], ldqc); + claset_("FULL", &jw, &jw, &c_b1, &c_b2, &zc[zc_offset], ldzc); +/* Computing 2nd power */ + i__1 = jw; +/* Computing 2nd power */ + i__3 = jw; + i__2 = *lwork - (i__3 * i__3 << 1); + i__4 = *rec + 1; + claqz0_("S", "V", "V", &jw, &c__1, &jw, &a[kwtop + kwtop * a_dim1], lda, & + b[kwtop + kwtop * b_dim1], ldb, &alpha[1], &beta[1], &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &work[(i__1 * i__1 << 1) + + 1], &i__2, &rwork[1], &i__4, &qz_small_info__); + if (qz_small_info__ != 0) { +/* Convergence failure, restore the window and exit */ + *nd = 0; + *ns = jw - qz_small_info__; + clacpy_("ALL", &jw, &jw, &work[1], &jw, &a[kwtop + kwtop * a_dim1], + lda); +/* Computing 2nd power */ + i__1 = jw; + clacpy_("ALL", &jw, &jw, &work[i__1 * i__1 + 1], &jw, &b[kwtop + + kwtop * b_dim1], ldb); + return; + } +/* Deflation detection loop */ + if (kwtop == *ilo || (s.r == 0.f && s.i == 0.f)) { + kwbot = kwtop - 1; + } else { + kwbot = *ihi; + k = 1; + k2 = 1; + while(k <= jw) { +/* Try to deflate eigenvalue */ + tempr = c_abs(&a[kwbot + kwbot * a_dim1]); + if (tempr == 0.f) { + tempr = c_abs(&s); + } + i__1 = (kwbot - kwtop + 1) * qc_dim1 + 1; + q__1.r = s.r * qc[i__1].r - s.i * qc[i__1].i, q__1.i = s.r * qc[ + i__1].i + s.i * qc[i__1].r; +/* Computing MAX */ + r__1 = ulp * tempr; + if (c_abs(&q__1) <= f2cmax(r__1,smlnum)) { +/* Deflatable */ + --kwbot; + } else { +/* Not deflatable, move out of the way */ + ifst = kwbot - kwtop + 1; + ilst = k2; + ctgexc_(&c_true, &c_true, &jw, &a[kwtop + kwtop * a_dim1], + lda, &b[kwtop + kwtop * b_dim1], ldb, &qc[qc_offset], + ldqc, &zc[zc_offset], ldzc, &ifst, &ilst, & + ctgexc_info__); + ++k2; + } + ++k; } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex float zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i= i__1; --k) { + clartg_(&a[k + (kwtop - 1) * a_dim1], &a[k + 1 + (kwtop - 1) * + a_dim1], &c1, &s1, &temp); + i__2 = k + (kwtop - 1) * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + i__2 = k + 1 + (kwtop - 1) * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* Computing MAX */ + i__2 = kwtop, i__3 = k - 1; + k2 = f2cmax(i__2,i__3); + i__2 = *ihi - k2 + 1; + crot_(&i__2, &a[k + k2 * a_dim1], lda, &a[k + 1 + k2 * a_dim1], + lda, &c1, &s1); + i__2 = *ihi - (k - 1) + 1; + crot_(&i__2, &b[k + (k - 1) * b_dim1], ldb, &b[k + 1 + (k - 1) * + b_dim1], ldb, &c1, &s1); + r_cnjg(&q__1, &s1); + crot_(&jw, &qc[(k - kwtop + 1) * qc_dim1 + 1], &c__1, &qc[(k + 1 + - kwtop + 1) * qc_dim1 + 1], &c__1, &c1, &q__1); } - pCf(z) = zdotc; -} -static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex double zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i= kwtop) { +/* Move bulge down and remove it */ + i__1 = kwbot - 1; + for (k2 = k; k2 <= i__1; ++k2) { + i__2 = kwtop + jw - 1; + claqz1_(&c_true, &c_true, &k2, &kwtop, &i__2, &kwbot, &a[ + a_offset], lda, &b[b_offset], ldb, &jw, &kwtop, &qc[ + qc_offset], ldqc, &jw, &kwtop, &zc[zc_offset], ldzc); + } + --k; } - pCd(z) = zdotc; -} -#endif + } +/* Apply Qc and Zc to rest of the matrix */ + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } + if (istopm - *ihi > 0) { + i__1 = istopm - *ihi; + cgemm_("C", "N", &jw, &i__1, &jw, &c_b2, &qc[qc_offset], ldqc, &a[ + kwtop + (*ihi + 1) * a_dim1], lda, &c_b1, &work[1], &jw); + i__1 = istopm - *ihi; + clacpy_("ALL", &jw, &i__1, &work[1], &jw, &a[kwtop + (*ihi + 1) * + a_dim1], lda); + i__1 = istopm - *ihi; + cgemm_("C", "N", &jw, &i__1, &jw, &c_b2, &qc[qc_offset], ldqc, &b[ + kwtop + (*ihi + 1) * b_dim1], ldb, &c_b1, &work[1], &jw); + i__1 = istopm - *ihi; + clacpy_("ALL", &jw, &i__1, &work[1], &jw, &b[kwtop + (*ihi + 1) * + b_dim1], ldb); + } + if (*ilq) { + cgemm_("N", "N", n, &jw, &jw, &c_b2, &q[kwtop * q_dim1 + 1], ldq, &qc[ + qc_offset], ldqc, &c_b1, &work[1], n); + clacpy_("ALL", n, &jw, &work[1], n, &q[kwtop * q_dim1 + 1], ldq); + } + if (kwtop - 1 - istartm + 1 > 0) { + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + cgemm_("N", "N", &i__1, &jw, &jw, &c_b2, &a[istartm + kwtop * a_dim1], + lda, &zc[zc_offset], ldzc, &c_b1, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + clacpy_("ALL", &i__1, &jw, &work[1], &i__2, &a[istartm + kwtop * + a_dim1], lda); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + cgemm_("N", "N", &i__1, &jw, &jw, &c_b2, &b[istartm + kwtop * b_dim1], + ldb, &zc[zc_offset], ldzc, &c_b1, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + clacpy_("ALL", &i__1, &jw, &work[1], &i__2, &b[istartm + kwtop * + b_dim1], ldb); + } + if (*ilz) { + cgemm_("N", "N", n, &jw, &jw, &c_b2, &z__[kwtop * z_dim1 + 1], ldz, & + zc[zc_offset], ldzc, &c_b1, &work[1], n) + ; + clacpy_("ALL", n, &jw, &work[1], n, &z__[kwtop * z_dim1 + 1], ldz); + } + return; +} /* claqz2_ */ + diff --git a/lapack-netlib/SRC/claqz3.c b/lapack-netlib/SRC/claqz3.c index 7856e080ff..5e6be729d2 100644 --- a/lapack-netlib/SRC/claqz3.c +++ b/lapack-netlib/SRC/claqz3.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -191,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -204,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -244,26 +247,25 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +290,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +317,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +345,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +379,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= *ihi) { + return; + } + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } + ns = *nshifts; +/* Computing MAX */ + i__1 = *nblock_desired__ - ns; + npos = f2cmax(i__1,1); +/* The following block introduces the shifts and chases */ +/* them down one by one just enough to make space for */ +/* the other shifts. The near-the-diagonal block is */ +/* of size (ns+1) x ns. */ + i__1 = ns + 1; + i__2 = ns + 1; + claset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &qc[qc_offset], ldqc); + claset_("FULL", &ns, &ns, &c_b1, &c_b2, &zc[zc_offset], ldzc); + i__1 = ns; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Introduce the shift */ + scale = sqrt(c_abs(&alpha[i__])) * sqrt(c_abs(&beta[i__])); + if (scale >= safmin && scale <= safmax) { + i__2 = i__; + i__3 = i__; + q__1.r = alpha[i__3].r / scale, q__1.i = alpha[i__3].i / scale; + alpha[i__2].r = q__1.r, alpha[i__2].i = q__1.i; + i__2 = i__; + i__3 = i__; + q__1.r = beta[i__3].r / scale, q__1.i = beta[i__3].i / scale; + beta[i__2].r = q__1.r, beta[i__2].i = q__1.i; + } + i__2 = i__; + i__3 = *ilo + *ilo * a_dim1; + q__2.r = beta[i__2].r * a[i__3].r - beta[i__2].i * a[i__3].i, q__2.i = + beta[i__2].r * a[i__3].i + beta[i__2].i * a[i__3].r; + i__4 = i__; + i__5 = *ilo + *ilo * b_dim1; + q__3.r = alpha[i__4].r * b[i__5].r - alpha[i__4].i * b[i__5].i, + q__3.i = alpha[i__4].r * b[i__5].i + alpha[i__4].i * b[i__5] + .r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + temp2.r = q__1.r, temp2.i = q__1.i; + i__2 = i__; + i__3 = *ilo + 1 + *ilo * a_dim1; + q__1.r = beta[i__2].r * a[i__3].r - beta[i__2].i * a[i__3].i, q__1.i = + beta[i__2].r * a[i__3].i + beta[i__2].i * a[i__3].r; + temp3.r = q__1.r, temp3.i = q__1.i; + if (c_abs(&temp2) > safmax || c_abs(&temp3) > safmax) { + temp2.r = 1.f, temp2.i = 0.f; + temp3.r = 0.f, temp3.i = 0.f; + } + clartg_(&temp2, &temp3, &c__, &s, &temp); + crot_(&ns, &a[*ilo + *ilo * a_dim1], lda, &a[*ilo + 1 + *ilo * a_dim1] + , lda, &c__, &s); + crot_(&ns, &b[*ilo + *ilo * b_dim1], ldb, &b[*ilo + 1 + *ilo * b_dim1] + , ldb, &c__, &s); + i__2 = ns + 1; + r_cnjg(&q__1, &s); + crot_(&i__2, &qc[qc_dim1 + 1], &c__1, &qc[(qc_dim1 << 1) + 1], &c__1, + &c__, &q__1); +/* Chase the shift down */ + i__2 = ns - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = *ihi - *ilo + 1; + i__4 = ns + 1; + claqz1_(&c_true, &c_true, &j, &c__1, &ns, &i__3, &a[*ilo + *ilo * + a_dim1], lda, &b[*ilo + *ilo * b_dim1], ldb, &i__4, &c__1, + &qc[qc_offset], ldqc, &ns, &c__1, &zc[zc_offset], ldzc); + } + } +/* Update the rest of the pencil */ +/* Update A(ilo:ilo+ns,ilo+ns:istopm) and B(ilo:ilo+ns,ilo+ns:istopm) */ +/* from the left with Qc(1:ns+1,1:ns+1)' */ + sheight = ns + 1; + swidth = istopm - (*ilo + ns) + 1; + if (swidth > 0) { + cgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &a[*ilo + (*ilo + ns) * a_dim1], lda, &c_b1, &work[1], & + sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ilo + (*ilo + + ns) * a_dim1], lda); + cgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &b[*ilo + (*ilo + ns) * b_dim1], ldb, &c_b1, &work[1], & + sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ilo + (*ilo + + ns) * b_dim1], ldb); + } + if (*ilq) { + cgemm_("N", "N", n, &sheight, &sheight, &c_b2, &q[*ilo * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b1, &work[1], n); + clacpy_("ALL", n, &sheight, &work[1], n, &q[*ilo * q_dim1 + 1], ldq); + } +/* Update A(istartm:ilo-1,ilo:ilo+ns-1) and B(istartm:ilo-1,ilo:ilo+ns-1) */ +/* from the right with Zc(1:ns,1:ns) */ + sheight = *ilo - 1 - istartm + 1; + swidth = ns; + if (sheight > 0) { + cgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &a[istartm + *ilo + * a_dim1], lda, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + * + ilo * a_dim1], lda); + cgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &b[istartm + *ilo + * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + * + ilo * b_dim1], ldb); + } + if (*ilz) { + cgemm_("N", "N", n, &swidth, &swidth, &c_b2, &z__[*ilo * z_dim1 + 1], + ldz, &zc[zc_offset], ldzc, &c_b1, &work[1], n); + clacpy_("ALL", n, &swidth, &work[1], n, &z__[*ilo * z_dim1 + 1], ldz); + } +/* The following block chases the shifts down to the bottom */ +/* right block. If possible, a shift is moved down npos */ +/* positions at a time */ + k = *ilo; + while(k < *ihi - ns) { +/* Computing MIN */ + i__1 = *ihi - ns - k; + np = f2cmin(i__1,npos); +/* Size of the near-the-diagonal block */ + nblock = ns + np; +/* istartb points to the first row we will be updating */ + istartb = k + 1; +/* istopb points to the last column we will be updating */ + istopb = k + nblock - 1; + i__1 = ns + np; + i__2 = ns + np; + claset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &qc[qc_offset], ldqc); + i__1 = ns + np; + i__2 = ns + np; + claset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &zc[zc_offset], ldzc); +/* Near the diagonal shift chase */ + for (i__ = ns - 1; i__ >= 0; --i__) { + i__1 = np - 1; + for (j = 0; j <= i__1; ++j) { +/* Move down the block with index k+i+j, updating */ +/* the (ns+np x ns+np) block: */ +/* (k:k+ns+np,k:k+ns+np-1) */ + i__2 = k + i__ + j; + i__3 = k + 1; + claqz1_(&c_true, &c_true, &i__2, &istartb, &istopb, ihi, &a[ + a_offset], lda, &b[b_offset], ldb, &nblock, &i__3, & + qc[qc_offset], ldqc, &nblock, &k, &zc[zc_offset], + ldzc); + } + } +/* Update rest of the pencil */ +/* Update A(k+1:k+ns+np, k+ns+np:istopm) and */ +/* B(k+1:k+ns+np, k+ns+np:istopm) */ +/* from the left with Qc(1:ns+np,1:ns+np)' */ + sheight = ns + np; + swidth = istopm - (k + ns + np) + 1; + if (swidth > 0) { + cgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[ + qc_offset], ldqc, &a[k + 1 + (k + ns + np) * a_dim1], lda, + &c_b1, &work[1], &sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[k + 1 + ( + k + ns + np) * a_dim1], lda); + cgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[ + qc_offset], ldqc, &b[k + 1 + (k + ns + np) * b_dim1], ldb, + &c_b1, &work[1], &sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[k + 1 + ( + k + ns + np) * b_dim1], ldb); + } + if (*ilq) { + cgemm_("N", "N", n, &nblock, &nblock, &c_b2, &q[(k + 1) * q_dim1 + + 1], ldq, &qc[qc_offset], ldqc, &c_b1, &work[1], n); + clacpy_("ALL", n, &nblock, &work[1], n, &q[(k + 1) * q_dim1 + 1], + ldq); + } +/* Update A(istartm:k,k:k+ns+npos-1) and B(istartm:k,k:k+ns+npos-1) */ +/* from the right with Zc(1:ns+np,1:ns+np) */ + sheight = k - istartm + 1; + swidth = nblock; + if (sheight > 0) { + cgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &a[istartm + + k * a_dim1], lda, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + + k * a_dim1], lda); + cgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &b[istartm + + k * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + + k * b_dim1], ldb); + } + if (*ilz) { + cgemm_("N", "N", n, &nblock, &nblock, &c_b2, &z__[k * z_dim1 + 1], + ldz, &zc[zc_offset], ldzc, &c_b1, &work[1], n); + clacpy_("ALL", n, &nblock, &work[1], n, &z__[k * z_dim1 + 1], ldz); + } + k += np; + } +/* The following block removes the shifts from the bottom right corner */ +/* one by one. Updates are initially applied to A(ihi-ns+1:ihi,ihi-ns:ihi). */ + claset_("FULL", &ns, &ns, &c_b1, &c_b2, &qc[qc_offset], ldqc); + i__1 = ns + 1; + i__2 = ns + 1; + claset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &zc[zc_offset], ldzc); +/* istartb points to the first row we will be updating */ + istartb = *ihi - ns + 1; +/* istopb points to the last column we will be updating */ + istopb = *ihi; + i__1 = ns; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Chase the shift down to the bottom right corner */ + i__2 = *ihi - 1; + for (ishift = *ihi - i__; ishift <= i__2; ++ishift) { + i__3 = *ihi - ns + 1; + i__4 = ns + 1; + i__5 = *ihi - ns; + claqz1_(&c_true, &c_true, &ishift, &istartb, &istopb, ihi, &a[ + a_offset], lda, &b[b_offset], ldb, &ns, &i__3, &qc[ + qc_offset], ldqc, &i__4, &i__5, &zc[zc_offset], ldzc); + } + } +/* Update rest of the pencil */ +/* Update A(ihi-ns+1:ihi, ihi+1:istopm) */ +/* from the left with Qc(1:ns,1:ns)' */ + sheight = ns; + swidth = istopm - (*ihi + 1) + 1; + if (swidth > 0) { + cgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &a[*ihi - ns + 1 + (*ihi + 1) * a_dim1], lda, &c_b1, & + work[1], &sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ihi - ns + + 1 + (*ihi + 1) * a_dim1], lda); + cgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &b[*ihi - ns + 1 + (*ihi + 1) * b_dim1], ldb, &c_b1, & + work[1], &sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ihi - ns + + 1 + (*ihi + 1) * b_dim1], ldb); + } + if (*ilq) { + cgemm_("N", "N", n, &ns, &ns, &c_b2, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b1, &work[1], n); + clacpy_("ALL", n, &ns, &work[1], n, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq); + } +/* Update A(istartm:ihi-ns,ihi-ns:ihi) */ +/* from the right with Zc(1:ns+1,1:ns+1) */ + sheight = *ihi - ns - istartm + 1; + swidth = ns + 1; + if (sheight > 0) { + cgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &a[istartm + (* + ihi - ns) * a_dim1], lda, &zc[zc_offset], ldzc, &c_b1, &work[ + 1], &sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + (* + ihi - ns) * a_dim1], lda); + cgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &b[istartm + (* + ihi - ns) * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b1, &work[ + 1], &sheight); + clacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + (* + ihi - ns) * b_dim1], ldb); + } + if (*ilz) { + i__1 = ns + 1; + i__2 = ns + 1; + cgemm_("N", "N", n, &i__1, &i__2, &c_b2, &z__[(*ihi - ns) * z_dim1 + + 1], ldz, &zc[zc_offset], ldzc, &c_b1, &work[1], n); + i__1 = ns + 1; + clacpy_("ALL", n, &i__1, &work[1], n, &z__[(*ihi - ns) * z_dim1 + 1], + ldz); + } + return; +} /* claqz3_ */ + diff --git a/lapack-netlib/SRC/dlaqz0.c b/lapack-netlib/SRC/dlaqz0.c index 6d7e7d5340..db8d12d12e 100644 --- a/lapack-netlib/SRC/dlaqz0.c +++ b/lapack-netlib/SRC/dlaqz0.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -18,6 +9,7 @@ #ifdef I #undef I #endif + #if defined(_WIN64) typedef long long BLASLONG; typedef unsigned long long BLASULONG; @@ -47,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -188,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -235,34 +208,27 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -287,6 +253,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -299,6 +280,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -311,6 +308,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -344,6 +342,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *n || *ihi < *ilo - 1) { + *info = -6; + } else if (*lda < *n) { + *info = -8; + } else if (*ldb < *n) { + *info = -10; + } else if (*ldq < 1 || (ilq && *ldq < *n)) { + *info = -15; + } else if (*ldz < 1 || (ilz && *ldz < *n)) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAQZ0", &i__1); + return; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1] = 1.; + return; + } + +/* Get the parameters */ + + *(unsigned char *)jbcmpz = *(unsigned char *)wants; + *(unsigned char *)&jbcmpz[1] = *(unsigned char *)wantq; + *(unsigned char *)&jbcmpz[2] = *(unsigned char *)wantz; + nmin = ilaenv_(&c__12, "DLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = ilaenv_(&c__13, "DLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + nibble = ilaenv_(&c__14, "DLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)3); + nsr = ilaenv_(&c__15, "DLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - * + ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + rcost = ilaenv_(&c__17, "DLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + itemp1 = (integer) (nsr / sqrt((nsr << 1) / ((doublereal) rcost / 100 * * + n) + 1)); + itemp1 = ((itemp1 - 1) / 4 << 2) + 4; + nbr = nsr + itemp1; + if (*n < nmin || *rec >= 2) { + dhgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &q[q_offset] + , ldq, &z__[z_offset], ldz, &work[1], lwork, info); + return; + } + +/* Find out required workspace */ + +/* Workspace query to dlaqz3 */ + nw = f2cmax(nwr,nmin); + dlaqz3_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nw, &a[a_offset], lda, &b[ + b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + n_undeflated__, &n_deflated__, &alphar[1], &alphai[1], &beta[1], & + work[1], &nw, &work[1], &nw, &work[1], &c_n1, rec, &aed_info__); + itemp1 = (integer) work[1]; +/* Workspace query to dlaqz4 */ + dlaqz4_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nsr, &nbr, &alphar[1], & + alphai[1], &beta[1], &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &work[1], &nbr, &work[1], & + nbr, &work[1], &c_n1, &sweep_info__); + itemp2 = (integer) work[1]; +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__4 = nbr; + i__1 = itemp1 + (i__3 * i__3 << 1), i__2 = itemp2 + (i__4 * i__4 << 1); + lworkreq = f2cmax(i__1,i__2); + if (*lwork == -1) { + work[1] = (doublereal) lworkreq; + return; + } else if (*lwork < lworkreq) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAQZ0", &i__1); + return; + } + +/* Initialize Q and Z */ + + if (iwantq == 3) { + dlaset_("FULL", n, n, &c_b25, &c_b26, &q[q_offset], ldq); + } + if (iwantz == 3) { + dlaset_("FULL", n, n, &c_b25, &c_b26, &z__[z_offset], ldz); + } +/* Get machine constants */ + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) (*n) / ulp); + i__1 = *ihi - *ilo + 1; + bnorm = dlanhs_("F", &i__1, &b[*ilo + *ilo * b_dim1], ldb, &work[1]); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * bnorm; + btol = f2cmax(d__1,d__2); + istart = *ilo; + istop = *ihi; + maxit = (*ihi - *ilo + 1) * 3; + ld = 0; + i__1 = maxit; + for (iiter = 1; iiter <= i__1; ++iiter) { + if (iiter >= maxit) { + *info = istop + 1; + goto L80; + } + if (istart + 1 >= istop) { + istop = istart; + myexit_(); + } +/* Check deflations at the end */ +/* Computing MAX */ + d__4 = smlnum, d__5 = ulp * ((d__1 = a[istop - 1 + (istop - 1) * + a_dim1], abs(d__1)) + (d__2 = a[istop - 2 + (istop - 2) * + a_dim1], abs(d__2))); + if ((d__3 = a[istop - 1 + (istop - 2) * a_dim1], abs(d__3)) <= f2cmax( + d__4,d__5)) { + a[istop - 1 + (istop - 2) * a_dim1] = 0.; + istop += -2; + ld = 0; + eshift = 0.; + } else /* if(complicated condition) */ { +/* Computing MAX */ + d__4 = smlnum, d__5 = ulp * ((d__1 = a[istop + istop * a_dim1], + abs(d__1)) + (d__2 = a[istop - 1 + (istop - 1) * a_dim1], + abs(d__2))); + if ((d__3 = a[istop + (istop - 1) * a_dim1], abs(d__3)) <= f2cmax( + d__4,d__5)) { + a[istop + (istop - 1) * a_dim1] = 0.; + --istop; + ld = 0; + eshift = 0.; + } + } +/* Check deflations at the start */ +/* Computing MAX */ + d__4 = smlnum, d__5 = ulp * ((d__1 = a[istart + 1 + (istart + 1) * + a_dim1], abs(d__1)) + (d__2 = a[istart + 2 + (istart + 2) * + a_dim1], abs(d__2))); + if ((d__3 = a[istart + 2 + (istart + 1) * a_dim1], abs(d__3)) <= f2cmax( + d__4,d__5)) { + a[istart + 2 + (istart + 1) * a_dim1] = 0.; + istart += 2; + ld = 0; + eshift = 0.; + } else /* if(complicated condition) */ { +/* Computing MAX */ + d__4 = smlnum, d__5 = ulp * ((d__1 = a[istart + istart * a_dim1], + abs(d__1)) + (d__2 = a[istart + 1 + (istart + 1) * a_dim1] + , abs(d__2))); + if ((d__3 = a[istart + 1 + istart * a_dim1], abs(d__3)) <= f2cmax( + d__4,d__5)) { + a[istart + 1 + istart * a_dim1] = 0.; + ++istart; + ld = 0; + eshift = 0.; + } + } + if (istart + 1 >= istop) { + myexit_(); + } +/* Check interior deflations */ + istart2 = istart; + i__2 = istart + 1; + for (k = istop; k >= i__2; --k) { +/* Computing MAX */ + d__4 = smlnum, d__5 = ulp * ((d__1 = a[k + k * a_dim1], abs(d__1)) + + (d__2 = a[k - 1 + (k - 1) * a_dim1], abs(d__2))); + if ((d__3 = a[k + (k - 1) * a_dim1], abs(d__3)) <= f2cmax(d__4,d__5)) + { + a[k + (k - 1) * a_dim1] = 0.; + istart2 = k; + myexit_(); + } + } +/* Get range to apply rotations to */ + if (ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = istart2; + istopm = istop; + } +/* Check infinite eigenvalues, this is done without blocking so might */ +/* slow down the method when many infinite eigenvalues are present */ + k = istop; + while(k >= istart2) { + if ((d__1 = b[k + k * b_dim1], abs(d__1)) < btol) { +/* A diagonal element of B is negligible, move it */ +/* to the top and deflate it */ + i__2 = istart2 + 1; + for (k2 = k; k2 >= i__2; --k2) { + dlartg_(&b[k2 - 1 + k2 * b_dim1], &b[k2 - 1 + (k2 - 1) * + b_dim1], &c1, &s1, &temp); + b[k2 - 1 + k2 * b_dim1] = temp; + b[k2 - 1 + (k2 - 1) * b_dim1] = 0.; + i__3 = k2 - 2 - istartm + 1; + drot_(&i__3, &b[istartm + k2 * b_dim1], &c__1, &b[istartm + + (k2 - 1) * b_dim1], &c__1, &c1, &s1); +/* Computing MIN */ + i__4 = k2 + 1; + i__3 = f2cmin(i__4,istop) - istartm + 1; + drot_(&i__3, &a[istartm + k2 * a_dim1], &c__1, &a[istartm + + (k2 - 1) * a_dim1], &c__1, &c1, &s1); + if (ilz) { + drot_(n, &z__[k2 * z_dim1 + 1], &c__1, &z__[(k2 - 1) * + z_dim1 + 1], &c__1, &c1, &s1); + } + if (k2 < istop) { + dlartg_(&a[k2 + (k2 - 1) * a_dim1], &a[k2 + 1 + (k2 - + 1) * a_dim1], &c1, &s1, &temp); + a[k2 + (k2 - 1) * a_dim1] = temp; + a[k2 + 1 + (k2 - 1) * a_dim1] = 0.; + i__3 = istopm - k2 + 1; + drot_(&i__3, &a[k2 + k2 * a_dim1], lda, &a[k2 + 1 + + k2 * a_dim1], lda, &c1, &s1); + i__3 = istopm - k2 + 1; + drot_(&i__3, &b[k2 + k2 * b_dim1], ldb, &b[k2 + 1 + + k2 * b_dim1], ldb, &c1, &s1); + if (ilq) { + drot_(n, &q[k2 * q_dim1 + 1], &c__1, &q[(k2 + 1) * + q_dim1 + 1], &c__1, &c1, &s1); + } + } + } + if (istart2 < istop) { + dlartg_(&a[istart2 + istart2 * a_dim1], &a[istart2 + 1 + + istart2 * a_dim1], &c1, &s1, &temp); + a[istart2 + istart2 * a_dim1] = temp; + a[istart2 + 1 + istart2 * a_dim1] = 0.; + i__2 = istopm - (istart2 + 1) + 1; + drot_(&i__2, &a[istart2 + (istart2 + 1) * a_dim1], lda, & + a[istart2 + 1 + (istart2 + 1) * a_dim1], lda, &c1, + &s1); + i__2 = istopm - (istart2 + 1) + 1; + drot_(&i__2, &b[istart2 + (istart2 + 1) * b_dim1], ldb, & + b[istart2 + 1 + (istart2 + 1) * b_dim1], ldb, &c1, + &s1); + if (ilq) { + drot_(n, &q[istart2 * q_dim1 + 1], &c__1, &q[(istart2 + + 1) * q_dim1 + 1], &c__1, &c1, &s1); + } + } + ++istart2; + } + --k; + } +/* istart2 now points to the top of the bottom right */ +/* unreduced Hessenberg block */ + if (istart2 >= istop) { + istop = istart2 - 1; + ld = 0; + eshift = 0.; + mycycle_(); + } + nw = nwr; + nshifts = nsr; + nblock = nbr; + if (istop - istart2 + 1 < nmin) { +/* Setting nw to the size of the subblock will make AED deflate */ +/* all the eigenvalues. This is slightly more efficient than just */ +/* using DHGEQZ because the off diagonal part gets updated via BLAS. */ + if (istop - istart + 1 < nmin) { + nw = istop - istart + 1; + istart2 = istart; + } else { + nw = istop - istart2 + 1; + } + } + +/* Time for AED */ + +/* Computing 2nd power */ + i__2 = nw; +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__5 = nw; + i__4 = *lwork - (i__5 * i__5 << 1); + dlaqz3_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &nw, &a[a_offset], + lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], + ldz, &n_undeflated__, &n_deflated__, &alphar[1], &alphai[1], & + beta[1], &work[1], &nw, &work[i__2 * i__2 + 1], &nw, &work[( + i__3 * i__3 << 1) + 1], &i__4, rec, &aed_info__); + if (n_deflated__ > 0) { + istop -= n_deflated__; + ld = 0; + eshift = 0.; + } + if (n_deflated__ * 100 > nibble * (n_deflated__ + n_undeflated__) || + istop - istart2 + 1 < nmin) { +/* AED has uncovered many eigenvalues. Skip a QZ sweep and run */ +/* AED again. */ + mycycle_(); + } + ++ld; +/* Computing MIN */ + i__2 = nshifts, i__3 = istop - istart2; + ns = f2cmin(i__2,i__3); + ns = f2cmin(ns,n_undeflated__); + shiftpos = istop - n_undeflated__ + 1; + +/* Shuffle shifts to put double shifts in front */ +/* This ensures that we don't split up a double shift */ + + i__2 = shiftpos + n_undeflated__ - 1; + for (i__ = shiftpos; i__ <= i__2; i__ += 2) { + if (alphai[i__] != -alphai[i__ + 1]) { + + swap = alphar[i__]; + alphar[i__] = alphar[i__ + 1]; + alphar[i__ + 1] = alphar[i__ + 2]; + alphar[i__ + 2] = swap; + swap = alphai[i__]; + alphai[i__] = alphai[i__ + 1]; + alphai[i__ + 1] = alphai[i__ + 2]; + alphai[i__ + 2] = swap; + swap = beta[i__]; + beta[i__] = beta[i__ + 1]; + beta[i__ + 1] = beta[i__ + 2]; + beta[i__ + 2] = swap; + } + } + if (ld % 6 == 0) { + +/* Exceptional shift. Chosen for no particularly good reason. */ + + if ((doublereal) maxit * safmin * (d__1 = a[istop + (istop - 1) * + a_dim1], abs(d__1)) < (d__2 = a[istop - 1 + (istop - 1) * + a_dim1], abs(d__2))) { + eshift = a[istop + (istop - 1) * a_dim1] / b[istop - 1 + ( + istop - 1) * b_dim1]; + } else { + eshift += 1. / (safmin * (doublereal) maxit); + } + alphar[shiftpos] = 1.; + alphar[shiftpos + 1] = 0.; + alphai[shiftpos] = 0.; + alphai[shiftpos + 1] = 0.; + beta[shiftpos] = eshift; + beta[shiftpos + 1] = eshift; + ns = 2; + } + +/* Time for a QZ sweep */ + +/* Computing 2nd power */ + i__2 = nblock; +/* Computing 2nd power */ + i__3 = nblock; +/* Computing 2nd power */ + i__5 = nblock; + i__4 = *lwork - (i__5 * i__5 << 1); + dlaqz4_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &ns, &nblock, & + alphar[shiftpos], &alphai[shiftpos], &beta[shiftpos], &a[ + a_offset], lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], &nblock, &work[i__2 * i__2 + 1], & + nblock, &work[(i__3 * i__3 << 1) + 1], &i__4, &sweep_info__); + } + +/* Call DHGEQZ to normalize the eigenvalue blocks and set the eigenvalues */ +/* If all the eigenvalues have been found, DHGEQZ will not do any iterations */ +/* and only normalize the blocks. In case of a rare convergence failure, */ +/* the single shift might perform better. */ + +L80: + dhgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], + ldb, &alphar[1], &alphai[1], &beta[1], &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], lwork, &norm_info__); + *info = norm_info__; + return; +} /* dlaqz0_ */ + diff --git a/lapack-netlib/SRC/dlaqz1.c b/lapack-netlib/SRC/dlaqz1.c index 7856e080ff..4bc6fae578 100644 --- a/lapack-netlib/SRC/dlaqz1.c +++ b/lapack-netlib/SRC/dlaqz1.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -236,34 +208,27 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +253,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +280,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +308,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +342,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= safmin && scale1 <= safmax) { + w[0] /= scale1; + w[1] /= scale1; + } + +/* Solve linear system */ + + w[1] /= b[(b_dim1 << 1) + 2]; + w[0] = (w[0] - b[(b_dim1 << 1) + 1] * w[1]) / b[b_dim1 + 1]; + scale2 = sqrt((abs(w[0]))) * sqrt((abs(w[1]))); + if (scale2 >= safmin && scale2 <= safmax) { + w[0] /= scale2; + w[1] /= scale2; + } + +/* Apply second shift */ + + v[1] = *beta2 * (a[a_dim1 + 1] * w[0] + a[(a_dim1 << 1) + 1] * w[1]) - * + sr2 * (b[b_dim1 + 1] * w[0] + b[(b_dim1 << 1) + 1] * w[1]); + v[2] = *beta2 * (a[a_dim1 + 2] * w[0] + a[(a_dim1 << 1) + 2] * w[1]) - * + sr2 * (b[b_dim1 + 2] * w[0] + b[(b_dim1 << 1) + 2] * w[1]); + v[3] = *beta2 * (a[a_dim1 + 3] * w[0] + a[(a_dim1 << 1) + 3] * w[1]) - * + sr2 * (b[b_dim1 + 3] * w[0] + b[(b_dim1 << 1) + 3] * w[1]); + +/* Account for imaginary part */ + + v[1] += *si * *si * b[b_dim1 + 1] / scale1 / scale2; + +/* Check for overflow */ + + if (abs(v[1]) > safmax || abs(v[2]) > safmax || abs(v[3]) > safmax || + disnan_(&v[1]) || disnan_(&v[2]) || disnan_(&v[3])) { + v[1] = 0.; + v[2] = 0.; + v[3] = 0.; + } + +/* End of DLAQZ1 */ + + return; +} /* dlaqz1_ */ + diff --git a/lapack-netlib/SRC/dlaqz2.c b/lapack-netlib/SRC/dlaqz2.c index 7856e080ff..4bbd8c78a3 100644 --- a/lapack-netlib/SRC/dlaqz2.c +++ b/lapack-netlib/SRC/dlaqz2.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -236,34 +208,27 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +253,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +280,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +308,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +342,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -236,34 +208,27 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +253,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +280,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +308,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +342,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *ilo) { + a[kwtop + (kwtop - 1) * a_dim1] = 0.; + } + } + } +/* Store window in case of convergence failure */ + dlacpy_("ALL", &jw, &jw, &a[kwtop + kwtop * a_dim1], lda, &work[1], &jw); +/* Computing 2nd power */ + i__1 = jw; + dlacpy_("ALL", &jw, &jw, &b[kwtop + kwtop * b_dim1], ldb, &work[i__1 * + i__1 + 1], &jw); +/* Transform window to real schur form */ + dlaset_("FULL", &jw, &jw, &c_b16, &c_b17, &qc[qc_offset], ldqc) + ; + dlaset_("FULL", &jw, &jw, &c_b16, &c_b17, &zc[zc_offset], ldzc) + ; +/* Computing 2nd power */ + i__1 = jw; +/* Computing 2nd power */ + i__3 = jw; + i__2 = *lwork - (i__3 * i__3 << 1); + i__4 = *rec + 1; + dlaqz0_("S", "V", "V", &jw, &c__1, &jw, &a[kwtop + kwtop * a_dim1], lda, & + b[kwtop + kwtop * b_dim1], ldb, &alphar[1], &alphai[1], &beta[1], + &qc[qc_offset], ldqc, &zc[zc_offset], ldzc, &work[(i__1 * i__1 << + 1) + 1], &i__2, &i__4, &qz_small_info__); + if (qz_small_info__ != 0) { +/* Convergence failure, restore the window and exit */ + *nd = 0; + *ns = jw - qz_small_info__; + dlacpy_("ALL", &jw, &jw, &work[1], &jw, &a[kwtop + kwtop * a_dim1], + lda); +/* Computing 2nd power */ + i__1 = jw; + dlacpy_("ALL", &jw, &jw, &work[i__1 * i__1 + 1], &jw, &b[kwtop + + kwtop * b_dim1], ldb); + return; + } +/* Deflation detection loop */ + if (kwtop == *ilo || s == 0.) { + kwbot = kwtop - 1; + } else { + kwbot = *ihi; + k = 1; + k2 = 1; + while(k <= jw) { + bulge = FALSE_; + if (kwbot - kwtop + 1 >= 2) { + bulge = a[kwbot + (kwbot - 1) * a_dim1] != 0.; + } + if (bulge) { +/* Try to deflate complex conjugate eigenvalue pair */ + temp = (d__3 = a[kwbot + kwbot * a_dim1], abs(d__3)) + sqrt(( + d__1 = a[kwbot + (kwbot - 1) * a_dim1], abs(d__1))) * + sqrt((d__2 = a[kwbot - 1 + kwbot * a_dim1], abs(d__2)) + ); + if (temp == 0.) { + temp = abs(s); + } +/* Computing MAX */ + d__3 = (d__1 = s * qc[(kwbot - kwtop) * qc_dim1 + 1], abs( + d__1)), d__4 = (d__2 = s * qc[(kwbot - kwtop + 1) * + qc_dim1 + 1], abs(d__2)); +/* Computing MAX */ + d__5 = smlnum, d__6 = ulp * temp; + if (f2cmax(d__3,d__4) <= f2cmax(d__5,d__6)) { +/* Deflatable */ + kwbot += -2; + } else { +/* Not deflatable, move out of the way */ + ifst = kwbot - kwtop + 1; + ilst = k2; + dtgexc_(&c_true, &c_true, &jw, &a[kwtop + kwtop * a_dim1], + lda, &b[kwtop + kwtop * b_dim1], ldb, &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &ifst, & + ilst, &work[1], lwork, &dtgexc_info__); + k2 += 2; + } + k += 2; + } else { +/* Try to deflate real eigenvalue */ + temp = (d__1 = a[kwbot + kwbot * a_dim1], abs(d__1)); + if (temp == 0.) { + temp = abs(s); + } +/* Computing MAX */ + d__2 = ulp * temp; + if ((d__1 = s * qc[(kwbot - kwtop + 1) * qc_dim1 + 1], abs( + d__1)) <= f2cmax(d__2,smlnum)) { +/* Deflatable */ + --kwbot; + } else { +/* Not deflatable, move out of the way */ + ifst = kwbot - kwtop + 1; + ilst = k2; + dtgexc_(&c_true, &c_true, &jw, &a[kwtop + kwtop * a_dim1], + lda, &b[kwtop + kwtop * b_dim1], ldb, &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &ifst, & + ilst, &work[1], lwork, &dtgexc_info__); + ++k2; + } + ++k; + } + } + } +/* Store eigenvalues */ + *nd = *ihi - kwbot; + *ns = jw - *nd; + k = kwtop; + while(k <= *ihi) { + bulge = FALSE_; + if (k < *ihi) { + if (a[k + 1 + k * a_dim1] != 0.) { + bulge = TRUE_; + } + } + if (bulge) { +/* 2x2 eigenvalue block */ + dlag2_(&a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, &safmin, + &beta[k], &beta[k + 1], &alphar[k], &alphar[k + 1], & + alphai[k]); + alphai[k + 1] = -alphai[k]; + k += 2; + } else { +/* 1x1 eigenvalue block */ + alphar[k] = a[k + k * a_dim1]; + alphai[k] = 0.; + beta[k] = b[k + k * b_dim1]; + ++k; + } + } + if (kwtop != *ilo && s != 0.) { +/* Reflect spike back, this will create optimally packed bulges */ +/* A( KWTOP:KWBOT, KWTOP-1 ) = A( KWTOP, KWTOP-1 )*QC( 1, */ +/* $ 1:JW-ND ) */ + i__1 = jw - *nd; + for (imk = 1; imk <= i__1; ++imk) { + mktmp = a[kwtop + (kwtop - 1) * a_dim1] * qc[imk * qc_dim1 + 1]; + } + i__1 = kwbot; + for (imk = kwtop; imk <= i__1; ++imk) { + a[imk + (kwtop - 1) * a_dim1] = mktmp; + } + i__1 = kwtop; + for (k = kwbot - 1; k >= i__1; --k) { + dlartg_(&a[k + (kwtop - 1) * a_dim1], &a[k + 1 + (kwtop - 1) * + a_dim1], &c1, &s1, &temp); + a[k + (kwtop - 1) * a_dim1] = temp; + a[k + 1 + (kwtop - 1) * a_dim1] = 0.; +/* Computing MAX */ + i__2 = kwtop, i__3 = k - 1; + k2 = f2cmax(i__2,i__3); + i__2 = *ihi - k2 + 1; + drot_(&i__2, &a[k + k2 * a_dim1], lda, &a[k + 1 + k2 * a_dim1], + lda, &c1, &s1); + i__2 = *ihi - (k - 1) + 1; + drot_(&i__2, &b[k + (k - 1) * b_dim1], ldb, &b[k + 1 + (k - 1) * + b_dim1], ldb, &c1, &s1); + drot_(&jw, &qc[(k - kwtop + 1) * qc_dim1 + 1], &c__1, &qc[(k + 1 + - kwtop + 1) * qc_dim1 + 1], &c__1, &c1, &s1); + } +/* Chase bulges down */ + istartm = kwtop; + istopm = *ihi; + k = kwbot - 1; + while(k >= kwtop) { + if (k >= kwtop + 1 && a[k + 1 + (k - 1) * a_dim1] != 0.) { +/* Move double pole block down and remove it */ + i__1 = kwbot - 2; + for (k2 = k - 1; k2 <= i__1; ++k2) { + i__2 = kwtop + jw - 1; + dlaqz2_(&c_true, &c_true, &k2, &kwtop, &i__2, &kwbot, &a[ + a_offset], lda, &b[b_offset], ldb, &jw, &kwtop, & + qc[qc_offset], ldqc, &jw, &kwtop, &zc[zc_offset], + ldzc); + } + k += -2; + } else { +/* k points to single shift */ + i__1 = kwbot - 2; + for (k2 = k; k2 <= i__1; ++k2) { +/* Move shift down */ + dlartg_(&b[k2 + 1 + (k2 + 1) * b_dim1], &b[k2 + 1 + k2 * + b_dim1], &c1, &s1, &temp); + b[k2 + 1 + (k2 + 1) * b_dim1] = temp; + b[k2 + 1 + k2 * b_dim1] = 0.; + i__2 = k2 + 2 - istartm + 1; + drot_(&i__2, &a[istartm + (k2 + 1) * a_dim1], &c__1, &a[ + istartm + k2 * a_dim1], &c__1, &c1, &s1); + i__2 = k2 - istartm + 1; + drot_(&i__2, &b[istartm + (k2 + 1) * b_dim1], &c__1, &b[ + istartm + k2 * b_dim1], &c__1, &c1, &s1); + drot_(&jw, &zc[(k2 + 1 - kwtop + 1) * zc_dim1 + 1], &c__1, + &zc[(k2 - kwtop + 1) * zc_dim1 + 1], &c__1, &c1, + &s1); + dlartg_(&a[k2 + 1 + k2 * a_dim1], &a[k2 + 2 + k2 * a_dim1] + , &c1, &s1, &temp); + a[k2 + 1 + k2 * a_dim1] = temp; + a[k2 + 2 + k2 * a_dim1] = 0.; + i__2 = istopm - k2; + drot_(&i__2, &a[k2 + 1 + (k2 + 1) * a_dim1], lda, &a[k2 + + 2 + (k2 + 1) * a_dim1], lda, &c1, &s1); + i__2 = istopm - k2; + drot_(&i__2, &b[k2 + 1 + (k2 + 1) * b_dim1], ldb, &b[k2 + + 2 + (k2 + 1) * b_dim1], ldb, &c1, &s1); + drot_(&jw, &qc[(k2 + 1 - kwtop + 1) * qc_dim1 + 1], &c__1, + &qc[(k2 + 2 - kwtop + 1) * qc_dim1 + 1], &c__1, & + c1, &s1); + } +/* Remove the shift */ + dlartg_(&b[kwbot + kwbot * b_dim1], &b[kwbot + (kwbot - 1) * + b_dim1], &c1, &s1, &temp); + b[kwbot + kwbot * b_dim1] = temp; + b[kwbot + (kwbot - 1) * b_dim1] = 0.; + i__1 = kwbot - istartm; + drot_(&i__1, &b[istartm + kwbot * b_dim1], &c__1, &b[istartm + + (kwbot - 1) * b_dim1], &c__1, &c1, &s1); + i__1 = kwbot - istartm + 1; + drot_(&i__1, &a[istartm + kwbot * a_dim1], &c__1, &a[istartm + + (kwbot - 1) * a_dim1], &c__1, &c1, &s1); + drot_(&jw, &zc[(kwbot - kwtop + 1) * zc_dim1 + 1], &c__1, &zc[ + (kwbot - 1 - kwtop + 1) * zc_dim1 + 1], &c__1, &c1, & + s1); + --k; + } + } + } +/* Apply Qc and Zc to rest of the matrix */ + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } + if (istopm - *ihi > 0) { + i__1 = istopm - *ihi; + dgemm_("T", "N", &jw, &i__1, &jw, &c_b17, &qc[qc_offset], ldqc, &a[ + kwtop + (*ihi + 1) * a_dim1], lda, &c_b16, &work[1], &jw); + i__1 = istopm - *ihi; + dlacpy_("ALL", &jw, &i__1, &work[1], &jw, &a[kwtop + (*ihi + 1) * + a_dim1], lda); + i__1 = istopm - *ihi; + dgemm_("T", "N", &jw, &i__1, &jw, &c_b17, &qc[qc_offset], ldqc, &b[ + kwtop + (*ihi + 1) * b_dim1], ldb, &c_b16, &work[1], &jw); + i__1 = istopm - *ihi; + dlacpy_("ALL", &jw, &i__1, &work[1], &jw, &b[kwtop + (*ihi + 1) * + b_dim1], ldb); + } + if (*ilq) { + dgemm_("N", "N", n, &jw, &jw, &c_b17, &q[kwtop * q_dim1 + 1], ldq, & + qc[qc_offset], ldqc, &c_b16, &work[1], n); + dlacpy_("ALL", n, &jw, &work[1], n, &q[kwtop * q_dim1 + 1], ldq); + } + if (kwtop - 1 - istartm + 1 > 0) { + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + dgemm_("N", "N", &i__1, &jw, &jw, &c_b17, &a[istartm + kwtop * a_dim1] + , lda, &zc[zc_offset], ldzc, &c_b16, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + dlacpy_("ALL", &i__1, &jw, &work[1], &i__2, &a[istartm + kwtop * + a_dim1], lda); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + dgemm_("N", "N", &i__1, &jw, &jw, &c_b17, &b[istartm + kwtop * b_dim1] + , ldb, &zc[zc_offset], ldzc, &c_b16, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + dlacpy_("ALL", &i__1, &jw, &work[1], &i__2, &b[istartm + kwtop * + b_dim1], ldb); + } + if (*ilz) { + dgemm_("N", "N", n, &jw, &jw, &c_b17, &z__[kwtop * z_dim1 + 1], ldz, & + zc[zc_offset], ldzc, &c_b16, &work[1], n); + dlacpy_("ALL", n, &jw, &work[1], n, &z__[kwtop * z_dim1 + 1], ldz); + } + return; +} /* dlaqz3_ */ + diff --git a/lapack-netlib/SRC/dlaqz4.c b/lapack-netlib/SRC/dlaqz4.c index 7856e080ff..32e25cf298 100644 --- a/lapack-netlib/SRC/dlaqz4.c +++ b/lapack-netlib/SRC/dlaqz4.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -236,34 +208,27 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +253,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +280,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +308,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +342,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= *ihi) { + return; + } + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } +/* Shuffle shifts into pairs of real shifts and pairs */ +/* of complex conjugate shifts assuming complex */ +/* conjugate shifts are already adjacent to one */ +/* another */ + i__1 = *nshifts - 2; + for (i__ = 1; i__ <= i__1; i__ += 2) { + if (si[i__] != -si[i__ + 1]) { + + swap = sr[i__]; + sr[i__] = sr[i__ + 1]; + sr[i__ + 1] = sr[i__ + 2]; + sr[i__ + 2] = swap; + swap = si[i__]; + si[i__] = si[i__ + 1]; + si[i__ + 1] = si[i__ + 2]; + si[i__ + 2] = swap; + swap = ss[i__]; + ss[i__] = ss[i__ + 1]; + ss[i__ + 1] = ss[i__ + 2]; + ss[i__ + 2] = swap; + } + } +/* NSHFTS is supposed to be even, but if it is odd, */ +/* then simply reduce it by one. The shuffle above */ +/* ensures that the dropped shift is real and that */ +/* the remaining shifts are paired. */ + ns = *nshifts - *nshifts % 2; +/* Computing MAX */ + i__1 = *nblock_desired__ - ns; + npos = f2cmax(i__1,1); +/* The following block introduces the shifts and chases */ +/* them down one by one just enough to make space for */ +/* the other shifts. The near-the-diagonal block is */ +/* of size (ns+1) x ns. */ + i__1 = ns + 1; + i__2 = ns + 1; + dlaset_("FULL", &i__1, &i__2, &c_b4, &c_b5, &qc[qc_offset], ldqc); + dlaset_("FULL", &ns, &ns, &c_b4, &c_b5, &zc[zc_offset], ldzc); + i__1 = ns; + for (i__ = 1; i__ <= i__1; i__ += 2) { +/* Introduce the shift */ + dlaqz1_(&a[*ilo + *ilo * a_dim1], lda, &b[*ilo + *ilo * b_dim1], ldb, + &sr[i__], &sr[i__ + 1], &si[i__], &ss[i__], &ss[i__ + 1], v); + temp = v[1]; + dlartg_(&temp, &v[2], &c1, &s1, &v[1]); + dlartg_(v, &v[1], &c2, &s2, &temp); + drot_(&ns, &a[*ilo + 1 + *ilo * a_dim1], lda, &a[*ilo + 2 + *ilo * + a_dim1], lda, &c1, &s1); + drot_(&ns, &a[*ilo + *ilo * a_dim1], lda, &a[*ilo + 1 + *ilo * a_dim1] + , lda, &c2, &s2); + drot_(&ns, &b[*ilo + 1 + *ilo * b_dim1], ldb, &b[*ilo + 2 + *ilo * + b_dim1], ldb, &c1, &s1); + drot_(&ns, &b[*ilo + *ilo * b_dim1], ldb, &b[*ilo + 1 + *ilo * b_dim1] + , ldb, &c2, &s2); + i__2 = ns + 1; + drot_(&i__2, &qc[(qc_dim1 << 1) + 1], &c__1, &qc[qc_dim1 * 3 + 1], & + c__1, &c1, &s1); + i__2 = ns + 1; + drot_(&i__2, &qc[qc_dim1 + 1], &c__1, &qc[(qc_dim1 << 1) + 1], &c__1, + &c2, &s2); +/* Chase the shift down */ + i__2 = ns - 1 - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = *ihi - *ilo + 1; + i__4 = ns + 1; + dlaqz2_(&c_true, &c_true, &j, &c__1, &ns, &i__3, &a[*ilo + *ilo * + a_dim1], lda, &b[*ilo + *ilo * b_dim1], ldb, &i__4, &c__1, + &qc[qc_offset], ldqc, &ns, &c__1, &zc[zc_offset], ldzc); + } + } +/* Update the rest of the pencil */ +/* Update A(ilo:ilo+ns,ilo+ns:istopm) and B(ilo:ilo+ns,ilo+ns:istopm) */ +/* from the left with Qc(1:ns+1,1:ns+1)' */ + sheight = ns + 1; + swidth = istopm - (*ilo + ns) + 1; + if (swidth > 0) { + dgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &a[*ilo + (*ilo + ns) * a_dim1], lda, &c_b4, &work[1], & + sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ilo + (*ilo + + ns) * a_dim1], lda); + dgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &b[*ilo + (*ilo + ns) * b_dim1], ldb, &c_b4, &work[1], & + sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ilo + (*ilo + + ns) * b_dim1], ldb); + } + if (*ilq) { + dgemm_("N", "N", n, &sheight, &sheight, &c_b5, &q[*ilo * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b4, &work[1], n); + dlacpy_("ALL", n, &sheight, &work[1], n, &q[*ilo * q_dim1 + 1], ldq); + } +/* Update A(istartm:ilo-1,ilo:ilo+ns-1) and B(istartm:ilo-1,ilo:ilo+ns-1) */ +/* from the right with Zc(1:ns,1:ns) */ + sheight = *ilo - 1 - istartm + 1; + swidth = ns; + if (sheight > 0) { + dgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &a[istartm + *ilo + * a_dim1], lda, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + * + ilo * a_dim1], lda); + dgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &b[istartm + *ilo + * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + * + ilo * b_dim1], ldb); + } + if (*ilz) { + dgemm_("N", "N", n, &swidth, &swidth, &c_b5, &z__[*ilo * z_dim1 + 1], + ldz, &zc[zc_offset], ldzc, &c_b4, &work[1], n); + dlacpy_("ALL", n, &swidth, &work[1], n, &z__[*ilo * z_dim1 + 1], ldz); + } +/* The following block chases the shifts down to the bottom */ +/* right block. If possible, a shift is moved down npos */ +/* positions at a time */ + k = *ilo; + while(k < *ihi - ns) { +/* Computing MIN */ + i__1 = *ihi - ns - k; + np = f2cmin(i__1,npos); +/* Size of the near-the-diagonal block */ + nblock = ns + np; +/* istartb points to the first row we will be updating */ + istartb = k + 1; +/* istopb points to the last column we will be updating */ + istopb = k + nblock - 1; + i__1 = ns + np; + i__2 = ns + np; + dlaset_("FULL", &i__1, &i__2, &c_b4, &c_b5, &qc[qc_offset], ldqc); + i__1 = ns + np; + i__2 = ns + np; + dlaset_("FULL", &i__1, &i__2, &c_b4, &c_b5, &zc[zc_offset], ldzc); +/* Near the diagonal shift chase */ + for (i__ = ns - 1; i__ >= 0; i__ += -2) { + i__1 = np - 1; + for (j = 0; j <= i__1; ++j) { +/* Move down the block with index k+i+j-1, updating */ +/* the (ns+np x ns+np) block: */ +/* (k:k+ns+np,k:k+ns+np-1) */ + i__2 = k + i__ + j - 1; + i__3 = k + 1; + dlaqz2_(&c_true, &c_true, &i__2, &istartb, &istopb, ihi, &a[ + a_offset], lda, &b[b_offset], ldb, &nblock, &i__3, & + qc[qc_offset], ldqc, &nblock, &k, &zc[zc_offset], + ldzc); + } + } +/* Update rest of the pencil */ +/* Update A(k+1:k+ns+np, k+ns+np:istopm) and */ +/* B(k+1:k+ns+np, k+ns+np:istopm) */ +/* from the left with Qc(1:ns+np,1:ns+np)' */ + sheight = ns + np; + swidth = istopm - (k + ns + np) + 1; + if (swidth > 0) { + dgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[ + qc_offset], ldqc, &a[k + 1 + (k + ns + np) * a_dim1], lda, + &c_b4, &work[1], &sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[k + 1 + ( + k + ns + np) * a_dim1], lda); + dgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[ + qc_offset], ldqc, &b[k + 1 + (k + ns + np) * b_dim1], ldb, + &c_b4, &work[1], &sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[k + 1 + ( + k + ns + np) * b_dim1], ldb); + } + if (*ilq) { + dgemm_("N", "N", n, &nblock, &nblock, &c_b5, &q[(k + 1) * q_dim1 + + 1], ldq, &qc[qc_offset], ldqc, &c_b4, &work[1], n); + dlacpy_("ALL", n, &nblock, &work[1], n, &q[(k + 1) * q_dim1 + 1], + ldq); + } +/* Update A(istartm:k,k:k+ns+npos-1) and B(istartm:k,k:k+ns+npos-1) */ +/* from the right with Zc(1:ns+np,1:ns+np) */ + sheight = k - istartm + 1; + swidth = nblock; + if (sheight > 0) { + dgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &a[istartm + + k * a_dim1], lda, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + + k * a_dim1], lda); + dgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &b[istartm + + k * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + + k * b_dim1], ldb); + } + if (*ilz) { + dgemm_("N", "N", n, &nblock, &nblock, &c_b5, &z__[k * z_dim1 + 1], + ldz, &zc[zc_offset], ldzc, &c_b4, &work[1], n); + dlacpy_("ALL", n, &nblock, &work[1], n, &z__[k * z_dim1 + 1], ldz); + } + k += np; + } +/* The following block removes the shifts from the bottom right corner */ +/* one by one. Updates are initially applied to A(ihi-ns+1:ihi,ihi-ns:ihi). */ + dlaset_("FULL", &ns, &ns, &c_b4, &c_b5, &qc[qc_offset], ldqc); + i__1 = ns + 1; + i__2 = ns + 1; + dlaset_("FULL", &i__1, &i__2, &c_b4, &c_b5, &zc[zc_offset], ldzc); +/* istartb points to the first row we will be updating */ + istartb = *ihi - ns + 1; +/* istopb points to the last column we will be updating */ + istopb = *ihi; + i__1 = ns; + for (i__ = 1; i__ <= i__1; i__ += 2) { +/* Chase the shift down to the bottom right corner */ + i__2 = *ihi - 2; + for (ishift = *ihi - i__ - 1; ishift <= i__2; ++ishift) { + i__3 = *ihi - ns + 1; + i__4 = ns + 1; + i__5 = *ihi - ns; + dlaqz2_(&c_true, &c_true, &ishift, &istartb, &istopb, ihi, &a[ + a_offset], lda, &b[b_offset], ldb, &ns, &i__3, &qc[ + qc_offset], ldqc, &i__4, &i__5, &zc[zc_offset], ldzc); + } + } +/* Update rest of the pencil */ +/* Update A(ihi-ns+1:ihi, ihi+1:istopm) */ +/* from the left with Qc(1:ns,1:ns)' */ + sheight = ns; + swidth = istopm - (*ihi + 1) + 1; + if (swidth > 0) { + dgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &a[*ihi - ns + 1 + (*ihi + 1) * a_dim1], lda, &c_b4, & + work[1], &sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ihi - ns + + 1 + (*ihi + 1) * a_dim1], lda); + dgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &b[*ihi - ns + 1 + (*ihi + 1) * b_dim1], ldb, &c_b4, & + work[1], &sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ihi - ns + + 1 + (*ihi + 1) * b_dim1], ldb); + } + if (*ilq) { + dgemm_("N", "N", n, &ns, &ns, &c_b5, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b4, &work[1], n); + dlacpy_("ALL", n, &ns, &work[1], n, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq); + } +/* Update A(istartm:ihi-ns,ihi-ns:ihi) */ +/* from the right with Zc(1:ns+1,1:ns+1) */ + sheight = *ihi - ns - istartm + 1; + swidth = ns + 1; + if (sheight > 0) { + dgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &a[istartm + (* + ihi - ns) * a_dim1], lda, &zc[zc_offset], ldzc, &c_b4, &work[ + 1], &sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + (* + ihi - ns) * a_dim1], lda); + dgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &b[istartm + (* + ihi - ns) * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b4, &work[ + 1], &sheight); + dlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + (* + ihi - ns) * b_dim1], ldb); + } + if (*ilz) { + i__1 = ns + 1; + i__2 = ns + 1; + dgemm_("N", "N", n, &i__1, &i__2, &c_b5, &z__[(*ihi - ns) * z_dim1 + + 1], ldz, &zc[zc_offset], ldzc, &c_b4, &work[1], n); + i__1 = ns + 1; + dlacpy_("ALL", n, &i__1, &work[1], n, &z__[(*ihi - ns) * z_dim1 + 1], + ldz); + } + return; +} /* dlaqz4_ */ + diff --git a/lapack-netlib/SRC/slaqz0.c b/lapack-netlib/SRC/slaqz0.c index cd8b585539..bd1a7cc224 100644 --- a/lapack-netlib/SRC/slaqz0.c +++ b/lapack-netlib/SRC/slaqz0.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -232,20 +204,823 @@ typedef struct Namelist Namelist; #define i_len(s, n) (n) #define i_nint(x) ((integer)u_nint(*(x))) #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); #endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *n || *ihi < *ilo - 1) { + *info = -6; + } else if (*lda < *n) { + *info = -8; + } else if (*ldb < *n) { + *info = -10; + } else if (*ldq < 1 || (ilq && *ldq < *n)) { + *info = -15; + } else if (*ldz < 1 || (ilz && *ldz < *n)) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAQZ0", &i__1); + return; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1] = 1.f; + return; + } + +/* Get the parameters */ + + *(unsigned char *)jbcmpz = *(unsigned char *)wants; + *(unsigned char *)&jbcmpz[1] = *(unsigned char *)wantq; + *(unsigned char *)&jbcmpz[2] = *(unsigned char *)wantz; + nmin = ilaenv_(&c__12, "SLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = ilaenv_(&c__13, "SLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + nibble = ilaenv_(&c__14, "SLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)3); + nsr = ilaenv_(&c__15, "SLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - * + ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + rcost = ilaenv_(&c__17, "SLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + itemp1 = (integer) ((real) nsr / sqrt((real) nsr * 2 / ((real) rcost / + 100 * (real) (*n)) + 1)); + itemp1 = ((itemp1 - 1) / 4 << 2) + 4; + nbr = nsr + itemp1; + if (*n < nmin || *rec >= 2) { + shgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &q[q_offset] + , ldq, &z__[z_offset], ldz, &work[1], lwork, info); + return; + } + +/* Find out required workspace */ + +/* Workspace query to slaqz3 */ + nw = f2cmax(nwr,nmin); + slaqz3_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nw, &a[a_offset], lda, &b[ + b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + n_undeflated__, &n_deflated__, &alphar[1], &alphai[1], &beta[1], & + work[1], &nw, &work[1], &nw, &work[1], &c_n1, rec, &aed_info__); + itemp1 = (integer) work[1]; +/* Workspace query to slaqz4 */ + slaqz4_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nsr, &nbr, &alphar[1], & + alphai[1], &beta[1], &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &work[1], &nbr, &work[1], & + nbr, &work[1], &c_n1, &sweep_info__); + itemp2 = (integer) work[1]; +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__4 = nbr; + i__1 = itemp1 + (i__3 * i__3 << 1), i__2 = itemp2 + (i__4 * i__4 << 1); + lworkreq = f2cmax(i__1,i__2); + if (*lwork == -1) { + work[1] = sroundup_lwork__(&lworkreq); + return; + } else if (*lwork < lworkreq) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAQZ0", &i__1); + return; + } + +/* Initialize Q and Z */ + + if (iwantq == 3) { + slaset_("FULL", n, n, &c_b25, &c_b26, &q[q_offset], ldq); + } + if (iwantz == 3) { + slaset_("FULL", n, n, &c_b25, &c_b26, &z__[z_offset], ldz); + } +/* Get machine constants */ + safmin = slamch_("SAFE MINIMUM"); + safmax = 1.f / safmin; + ulp = slamch_("PRECISION"); + smlnum = safmin * ((real) (*n) / ulp); + i__1 = *ihi - *ilo + 1; + bnorm = slanhs_("F", &i__1, &b[*ilo + *ilo * b_dim1], ldb, &work[1]); +/* Computing MAX */ + r__1 = safmin, r__2 = ulp * bnorm; + btol = f2cmax(r__1,r__2); + istart = *ilo; + istop = *ihi; + maxit = (*ihi - *ilo + 1) * 3; + ld = 0; + i__1 = maxit; + for (iiter = 1; iiter <= i__1; ++iiter) { + if (iiter >= maxit) { + *info = istop + 1; + goto L80; + } + if (istart + 1 >= istop) { + istop = istart; + myexit_(); + } +/* Check deflations at the end */ +/* Computing MAX */ + r__4 = smlnum, r__5 = ulp * ((r__1 = a[istop - 1 + (istop - 1) * + a_dim1], abs(r__1)) + (r__2 = a[istop - 2 + (istop - 2) * + a_dim1], abs(r__2))); + if ((r__3 = a[istop - 1 + (istop - 2) * a_dim1], abs(r__3)) <= f2cmax( + r__4,r__5)) { + a[istop - 1 + (istop - 2) * a_dim1] = 0.f; + istop += -2; + ld = 0; + eshift = 0.f; + } else /* if(complicated condition) */ { +/* Computing MAX */ + r__4 = smlnum, r__5 = ulp * ((r__1 = a[istop + istop * a_dim1], + abs(r__1)) + (r__2 = a[istop - 1 + (istop - 1) * a_dim1], + abs(r__2))); + if ((r__3 = a[istop + (istop - 1) * a_dim1], abs(r__3)) <= f2cmax( + r__4,r__5)) { + a[istop + (istop - 1) * a_dim1] = 0.f; + --istop; + ld = 0; + eshift = 0.f; + } + } +/* Check deflations at the start */ +/* Computing MAX */ + r__4 = smlnum, r__5 = ulp * ((r__1 = a[istart + 1 + (istart + 1) * + a_dim1], abs(r__1)) + (r__2 = a[istart + 2 + (istart + 2) * + a_dim1], abs(r__2))); + if ((r__3 = a[istart + 2 + (istart + 1) * a_dim1], abs(r__3)) <= f2cmax( + r__4,r__5)) { + a[istart + 2 + (istart + 1) * a_dim1] = 0.f; + istart += 2; + ld = 0; + eshift = 0.f; + } else /* if(complicated condition) */ { +/* Computing MAX */ + r__4 = smlnum, r__5 = ulp * ((r__1 = a[istart + istart * a_dim1], + abs(r__1)) + (r__2 = a[istart + 1 + (istart + 1) * a_dim1] + , abs(r__2))); + if ((r__3 = a[istart + 1 + istart * a_dim1], abs(r__3)) <= f2cmax( + r__4,r__5)) { + a[istart + 1 + istart * a_dim1] = 0.f; + ++istart; + ld = 0; + eshift = 0.f; + } + } + if (istart + 1 >= istop) { + myexit_(); + } +/* Check interior deflations */ + istart2 = istart; + i__2 = istart + 1; + for (k = istop; k >= i__2; --k) { +/* Computing MAX */ + r__4 = smlnum, r__5 = ulp * ((r__1 = a[k + k * a_dim1], abs(r__1)) + + (r__2 = a[k - 1 + (k - 1) * a_dim1], abs(r__2))); + if ((r__3 = a[k + (k - 1) * a_dim1], abs(r__3)) <= f2cmax(r__4,r__5)) + { + a[k + (k - 1) * a_dim1] = 0.f; + istart2 = k; + myexit_(); + } + } +/* Get range to apply rotations to */ + if (ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = istart2; + istopm = istop; + } +/* Check infinite eigenvalues, this is done without blocking so might */ +/* slow down the method when many infinite eigenvalues are present */ + k = istop; + while(k >= istart2) { + if ((r__1 = b[k + k * b_dim1], abs(r__1)) < btol) { +/* A diagonal element of B is negligible, move it */ +/* to the top and deflate it */ + i__2 = istart2 + 1; + for (k2 = k; k2 >= i__2; --k2) { + slartg_(&b[k2 - 1 + k2 * b_dim1], &b[k2 - 1 + (k2 - 1) * + b_dim1], &c1, &s1, &temp); + b[k2 - 1 + k2 * b_dim1] = temp; + b[k2 - 1 + (k2 - 1) * b_dim1] = 0.f; + i__3 = k2 - 2 - istartm + 1; + srot_(&i__3, &b[istartm + k2 * b_dim1], &c__1, &b[istartm + + (k2 - 1) * b_dim1], &c__1, &c1, &s1); +/* Computing MIN */ + i__4 = k2 + 1; + i__3 = f2cmin(i__4,istop) - istartm + 1; + srot_(&i__3, &a[istartm + k2 * a_dim1], &c__1, &a[istartm + + (k2 - 1) * a_dim1], &c__1, &c1, &s1); + if (ilz) { + srot_(n, &z__[k2 * z_dim1 + 1], &c__1, &z__[(k2 - 1) * + z_dim1 + 1], &c__1, &c1, &s1); + } + if (k2 < istop) { + slartg_(&a[k2 + (k2 - 1) * a_dim1], &a[k2 + 1 + (k2 - + 1) * a_dim1], &c1, &s1, &temp); + a[k2 + (k2 - 1) * a_dim1] = temp; + a[k2 + 1 + (k2 - 1) * a_dim1] = 0.f; + i__3 = istopm - k2 + 1; + srot_(&i__3, &a[k2 + k2 * a_dim1], lda, &a[k2 + 1 + + k2 * a_dim1], lda, &c1, &s1); + i__3 = istopm - k2 + 1; + srot_(&i__3, &b[k2 + k2 * b_dim1], ldb, &b[k2 + 1 + + k2 * b_dim1], ldb, &c1, &s1); + if (ilq) { + srot_(n, &q[k2 * q_dim1 + 1], &c__1, &q[(k2 + 1) * + q_dim1 + 1], &c__1, &c1, &s1); + } + } + } + if (istart2 < istop) { + slartg_(&a[istart2 + istart2 * a_dim1], &a[istart2 + 1 + + istart2 * a_dim1], &c1, &s1, &temp); + a[istart2 + istart2 * a_dim1] = temp; + a[istart2 + 1 + istart2 * a_dim1] = 0.f; + i__2 = istopm - (istart2 + 1) + 1; + srot_(&i__2, &a[istart2 + (istart2 + 1) * a_dim1], lda, & + a[istart2 + 1 + (istart2 + 1) * a_dim1], lda, &c1, + &s1); + i__2 = istopm - (istart2 + 1) + 1; + srot_(&i__2, &b[istart2 + (istart2 + 1) * b_dim1], ldb, & + b[istart2 + 1 + (istart2 + 1) * b_dim1], ldb, &c1, + &s1); + if (ilq) { + srot_(n, &q[istart2 * q_dim1 + 1], &c__1, &q[(istart2 + + 1) * q_dim1 + 1], &c__1, &c1, &s1); + } + } + ++istart2; + } + --k; + } +/* istart2 now points to the top of the bottom right */ +/* unreduced Hessenberg block */ + if (istart2 >= istop) { + istop = istart2 - 1; + ld = 0; + eshift = 0.f; + mycycle_(); + } + nw = nwr; + nshifts = nsr; + nblock = nbr; + if (istop - istart2 + 1 < nmin) { +/* Setting nw to the size of the subblock will make AED deflate */ +/* all the eigenvalues. This is slightly more efficient than just */ +/* using qz_small because the off diagonal part gets updated via BLAS. */ + if (istop - istart + 1 < nmin) { + nw = istop - istart + 1; + istart2 = istart; + } else { + nw = istop - istart2 + 1; + } + } + +/* Time for AED */ + +/* Computing 2nd power */ + i__2 = nw; +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__5 = nw; + i__4 = *lwork - (i__5 * i__5 << 1); + slaqz3_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &nw, &a[a_offset], + lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], + ldz, &n_undeflated__, &n_deflated__, &alphar[1], &alphai[1], & + beta[1], &work[1], &nw, &work[i__2 * i__2 + 1], &nw, &work[( + i__3 * i__3 << 1) + 1], &i__4, rec, &aed_info__); + if (n_deflated__ > 0) { + istop -= n_deflated__; + ld = 0; + eshift = 0.f; + } + if (n_deflated__ * 100 > nibble * (n_deflated__ + n_undeflated__) || + istop - istart2 + 1 < nmin) { +/* AED has uncovered many eigenvalues. Skip a QZ sweep and run */ +/* AED again. */ + mycycle_(); + } + ++ld; +/* Computing MIN */ + i__2 = nshifts, i__3 = istop - istart2; + ns = f2cmin(i__2,i__3); + ns = f2cmin(ns,n_undeflated__); + shiftpos = istop - n_undeflated__ + 1; + +/* Shuffle shifts to put double shifts in front */ +/* This ensures that we don't split up a double shift */ + + i__2 = shiftpos + n_undeflated__ - 1; + for (i__ = shiftpos; i__ <= i__2; i__ += 2) { + if (alphai[i__] != -alphai[i__ + 1]) { + + swap = alphar[i__]; + alphar[i__] = alphar[i__ + 1]; + alphar[i__ + 1] = alphar[i__ + 2]; + alphar[i__ + 2] = swap; + swap = alphai[i__]; + alphai[i__] = alphai[i__ + 1]; + alphai[i__ + 1] = alphai[i__ + 2]; + alphai[i__ + 2] = swap; + swap = beta[i__]; + beta[i__] = beta[i__ + 1]; + beta[i__ + 1] = beta[i__ + 2]; + beta[i__ + 2] = swap; + } + } + if (ld % 6 == 0) { + +/* Exceptional shift. Chosen for no particularly good reason. */ + + if ((real) maxit * safmin * (r__1 = a[istop + (istop - 1) * + a_dim1], abs(r__1)) < (r__2 = a[istop - 1 + (istop - 1) * + a_dim1], abs(r__2))) { + eshift = a[istop + (istop - 1) * a_dim1] / b[istop - 1 + ( + istop - 1) * b_dim1]; + } else { + eshift += 1.f / (safmin * (real) maxit); + } + alphar[shiftpos] = 1.f; + alphar[shiftpos + 1] = 0.f; + alphai[shiftpos] = 0.f; + alphai[shiftpos + 1] = 0.f; + beta[shiftpos] = eshift; + beta[shiftpos + 1] = eshift; + ns = 2; + } + +/* Time for a QZ sweep */ + +/* Computing 2nd power */ + i__2 = nblock; +/* Computing 2nd power */ + i__3 = nblock; +/* Computing 2nd power */ + i__5 = nblock; + i__4 = *lwork - (i__5 * i__5 << 1); + slaqz4_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &ns, &nblock, & + alphar[shiftpos], &alphai[shiftpos], &beta[shiftpos], &a[ + a_offset], lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], &nblock, &work[i__2 * i__2 + 1], & + nblock, &work[(i__3 * i__3 << 1) + 1], &i__4, &sweep_info__); + } + +/* Call SHGEQZ to normalize the eigenvalue blocks and set the eigenvalues */ +/* If all the eigenvalues have been found, SHGEQZ will not do any iterations */ +/* and only normalize the blocks. In case of a rare convergence failure, */ +/* the single shift might perform better. */ + +L80: + shgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], + ldb, &alphar[1], &alphai[1], &beta[1], &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], lwork, &norm_info__); + *info = norm_info__; + return; +} /* slaqz0_ */ diff --git a/lapack-netlib/SRC/slaqz1.c b/lapack-netlib/SRC/slaqz1.c index 7856e080ff..e819079a71 100644 --- a/lapack-netlib/SRC/slaqz1.c +++ b/lapack-netlib/SRC/slaqz1.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -232,171 +204,106 @@ typedef struct Namelist Namelist; #define i_len(s, n) (n) #define i_nint(x) ((integer)u_nint(*(x))) #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) -#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) -#define pow_si(B,E) spow_ui(*(B),*(E)) -#define pow_ri(B,E) spow_ui(*(B),*(E)) -#define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) + +/* Subroutine */ void slaqz1_(real *a, integer *lda, real *b, integer *ldb, + real *sr1, real *sr2, real *si, real *beta1, real *beta2, real *v) { - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex float zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i= safmin && scale1 <= safmax) { + w[0] /= scale1; + w[1] /= scale1; + } + +/* Solve linear system */ + + w[1] /= b[(b_dim1 << 1) + 2]; + w[0] = (w[0] - b[(b_dim1 << 1) + 1] * w[1]) / b[b_dim1 + 1]; + scale2 = sqrt((abs(w[0]))) * sqrt((abs(w[1]))); + if (scale2 >= safmin && scale2 <= safmax) { + w[0] /= scale2; + w[1] /= scale2; + } + +/* Apply second shift */ + + v[1] = *beta2 * (a[a_dim1 + 1] * w[0] + a[(a_dim1 << 1) + 1] * w[1]) - * + sr2 * (b[b_dim1 + 1] * w[0] + b[(b_dim1 << 1) + 1] * w[1]); + v[2] = *beta2 * (a[a_dim1 + 2] * w[0] + a[(a_dim1 << 1) + 2] * w[1]) - * + sr2 * (b[b_dim1 + 2] * w[0] + b[(b_dim1 << 1) + 2] * w[1]); + v[3] = *beta2 * (a[a_dim1 + 3] * w[0] + a[(a_dim1 << 1) + 3] * w[1]) - * + sr2 * (b[b_dim1 + 3] * w[0] + b[(b_dim1 << 1) + 3] * w[1]); + +/* Account for imaginary part */ + + v[1] += *si * *si * b[b_dim1 + 1] / scale1 / scale2; + +/* Check for overflow */ + + if (abs(v[1]) > safmax || abs(v[2]) > safmax || abs(v[3]) > safmax || + sisnan_(&v[1]) || sisnan_(&v[2]) || sisnan_(&v[3])) { + v[1] = 0.f; + v[2] = 0.f; + v[3] = 0.f; + } + +/* End of SLAQZ1 */ + + return; +} /* slaqz1_ */ + diff --git a/lapack-netlib/SRC/slaqz2.c b/lapack-netlib/SRC/slaqz2.c index 7856e080ff..5eb7b9222b 100644 --- a/lapack-netlib/SRC/slaqz2.c +++ b/lapack-netlib/SRC/slaqz2.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -232,171 +204,228 @@ typedef struct Namelist Namelist; #define i_len(s, n) (n) #define i_nint(x) ((integer)u_nint(*(x))) #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) -#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) -#define pow_si(B,E) spow_ui(*(B),*(E)) -#define pow_ri(B,E) spow_ui(*(B),*(E)) -#define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) + +/* Table of constant values */ + +static integer c__2 = 2; +static integer c__1 = 1; + +/* Subroutine */ void slaqz2_(logical *ilq, logical *ilz, integer *k, integer * + istartm, integer *istopm, integer *ihi, real *a, integer *lda, real * + b, integer *ldb, integer *nq, integer *qstart, real *q, integer *ldq, + integer *nz, integer *zstart, real *z__, integer *ldz) { - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex float zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -232,38 +204,27 @@ typedef struct Namelist Namelist; #define i_len(s, n) (n) #define i_nint(x) ((integer)u_nint(*(x))) #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) -#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) -#define pow_si(B,E) spow_ui(*(B),*(E)) -#define pow_ri(B,E) spow_ui(*(B),*(E)) -#define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +249,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +276,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +304,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +338,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *ilo) { + a[kwtop + (kwtop - 1) * a_dim1] = 0.f; + } + } + } +/* Store window in case of convergence failure */ + slacpy_("ALL", &jw, &jw, &a[kwtop + kwtop * a_dim1], lda, &work[1], &jw); +/* Computing 2nd power */ + i__1 = jw; + slacpy_("ALL", &jw, &jw, &b[kwtop + kwtop * b_dim1], ldb, &work[i__1 * + i__1 + 1], &jw); +/* Transform window to real schur form */ + slaset_("FULL", &jw, &jw, &c_b16, &c_b17, &qc[qc_offset], ldqc) + ; + slaset_("FULL", &jw, &jw, &c_b16, &c_b17, &zc[zc_offset], ldzc) + ; +/* Computing 2nd power */ + i__1 = jw; +/* Computing 2nd power */ + i__3 = jw; + i__2 = *lwork - (i__3 * i__3 << 1); + i__4 = *rec + 1; + slaqz0_("S", "V", "V", &jw, &c__1, &jw, &a[kwtop + kwtop * a_dim1], lda, & + b[kwtop + kwtop * b_dim1], ldb, &alphar[1], &alphai[1], &beta[1], + &qc[qc_offset], ldqc, &zc[zc_offset], ldzc, &work[(i__1 * i__1 << + 1) + 1], &i__2, &i__4, &qz_small_info__); + if (qz_small_info__ != 0) { +/* Convergence failure, restore the window and exit */ + *nd = 0; + *ns = jw - qz_small_info__; + slacpy_("ALL", &jw, &jw, &work[1], &jw, &a[kwtop + kwtop * a_dim1], + lda); +/* Computing 2nd power */ + i__1 = jw; + slacpy_("ALL", &jw, &jw, &work[i__1 * i__1 + 1], &jw, &b[kwtop + + kwtop * b_dim1], ldb); + return; + } +/* Deflation detection loop */ + if (kwtop == *ilo || s == 0.f) { + kwbot = kwtop - 1; + } else { + kwbot = *ihi; + k = 1; + k2 = 1; + while(k <= jw) { + bulge = FALSE_; + if (kwbot - kwtop + 1 >= 2) { + bulge = a[kwbot + (kwbot - 1) * a_dim1] != 0.f; + } + if (bulge) { +/* Try to deflate complex conjugate eigenvalue pair */ + temp = (r__3 = a[kwbot + kwbot * a_dim1], abs(r__3)) + sqrt(( + r__1 = a[kwbot + (kwbot - 1) * a_dim1], abs(r__1))) * + sqrt((r__2 = a[kwbot - 1 + kwbot * a_dim1], abs(r__2)) + ); + if (temp == 0.f) { + temp = abs(s); + } +/* Computing MAX */ + r__3 = (r__1 = s * qc[(kwbot - kwtop) * qc_dim1 + 1], abs( + r__1)), r__4 = (r__2 = s * qc[(kwbot - kwtop + 1) * + qc_dim1 + 1], abs(r__2)); +/* Computing MAX */ + r__5 = smlnum, r__6 = ulp * temp; + if (f2cmax(r__3,r__4) <= f2cmax(r__5,r__6)) { +/* Deflatable */ + kwbot += -2; + } else { +/* Not deflatable, move out of the way */ + ifst = kwbot - kwtop + 1; + ilst = k2; + stgexc_(&c_true, &c_true, &jw, &a[kwtop + kwtop * a_dim1], + lda, &b[kwtop + kwtop * b_dim1], ldb, &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &ifst, & + ilst, &work[1], lwork, &stgexc_info__); + k2 += 2; + } + k += 2; + } else { +/* Try to deflate real eigenvalue */ + temp = (r__1 = a[kwbot + kwbot * a_dim1], abs(r__1)); + if (temp == 0.f) { + temp = abs(s); + } +/* Computing MAX */ + r__2 = ulp * temp; + if ((r__1 = s * qc[(kwbot - kwtop + 1) * qc_dim1 + 1], abs( + r__1)) <= f2cmax(r__2,smlnum)) { +/* Deflatable */ + --kwbot; + } else { +/* Not deflatable, move out of the way */ + ifst = kwbot - kwtop + 1; + ilst = k2; + stgexc_(&c_true, &c_true, &jw, &a[kwtop + kwtop * a_dim1], + lda, &b[kwtop + kwtop * b_dim1], ldb, &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &ifst, & + ilst, &work[1], lwork, &stgexc_info__); + ++k2; + } + ++k; + } + } + } +/* Store eigenvalues */ + *nd = *ihi - kwbot; + *ns = jw - *nd; + k = kwtop; + while(k <= *ihi) { + bulge = FALSE_; + if (k < *ihi) { + if (a[k + 1 + k * a_dim1] != 0.f) { + bulge = TRUE_; + } + } + if (bulge) { +/* 2x2 eigenvalue block */ + slag2_(&a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, &safmin, + &beta[k], &beta[k + 1], &alphar[k], &alphar[k + 1], & + alphai[k]); + alphai[k + 1] = -alphai[k]; + k += 2; + } else { +/* 1x1 eigenvalue block */ + alphar[k] = a[k + k * a_dim1]; + alphai[k] = 0.f; + beta[k] = b[k + k * b_dim1]; + ++k; + } + } + if (kwtop != *ilo && s != 0.f) { +/* Reflect spike back, this will create optimally packed bulges */ +/* A( KWTOP:KWBOT, KWTOP-1 ) = A( KWTOP, KWTOP-1 )*QC( 1, */ +/* $ 1:JW-ND ) */ + i__1 = jw - *nd; + for (imk = 1; imk <= i__1; ++imk) { + mktmp = a[kwtop + (kwtop - 1) * a_dim1] * qc[imk * qc_dim1 + 1]; + } + i__1 = kwbot; + for (imk = kwtop; imk <= i__1; ++imk) { + a[imk + (kwtop - 1) * a_dim1] = mktmp; + } + i__1 = kwtop; + for (k = kwbot - 1; k >= i__1; --k) { + slartg_(&a[k + (kwtop - 1) * a_dim1], &a[k + 1 + (kwtop - 1) * + a_dim1], &c1, &s1, &temp); + a[k + (kwtop - 1) * a_dim1] = temp; + a[k + 1 + (kwtop - 1) * a_dim1] = 0.f; +/* Computing MAX */ + i__2 = kwtop, i__3 = k - 1; + k2 = f2cmax(i__2,i__3); + i__2 = *ihi - k2 + 1; + srot_(&i__2, &a[k + k2 * a_dim1], lda, &a[k + 1 + k2 * a_dim1], + lda, &c1, &s1); + i__2 = *ihi - (k - 1) + 1; + srot_(&i__2, &b[k + (k - 1) * b_dim1], ldb, &b[k + 1 + (k - 1) * + b_dim1], ldb, &c1, &s1); + srot_(&jw, &qc[(k - kwtop + 1) * qc_dim1 + 1], &c__1, &qc[(k + 1 + - kwtop + 1) * qc_dim1 + 1], &c__1, &c1, &s1); + } +/* Chase bulges down */ + istartm = kwtop; + istopm = *ihi; + k = kwbot - 1; + while(k >= kwtop) { + if (k >= kwtop + 1 && a[k + 1 + (k - 1) * a_dim1] != 0.f) { +/* Move double pole block down and remove it */ + i__1 = kwbot - 2; + for (k2 = k - 1; k2 <= i__1; ++k2) { + i__2 = kwtop + jw - 1; + slaqz2_(&c_true, &c_true, &k2, &kwtop, &i__2, &kwbot, &a[ + a_offset], lda, &b[b_offset], ldb, &jw, &kwtop, & + qc[qc_offset], ldqc, &jw, &kwtop, &zc[zc_offset], + ldzc); + } + k += -2; + } else { +/* k points to single shift */ + i__1 = kwbot - 2; + for (k2 = k; k2 <= i__1; ++k2) { +/* Move shift down */ + slartg_(&b[k2 + 1 + (k2 + 1) * b_dim1], &b[k2 + 1 + k2 * + b_dim1], &c1, &s1, &temp); + b[k2 + 1 + (k2 + 1) * b_dim1] = temp; + b[k2 + 1 + k2 * b_dim1] = 0.f; + i__2 = k2 + 2 - istartm + 1; + srot_(&i__2, &a[istartm + (k2 + 1) * a_dim1], &c__1, &a[ + istartm + k2 * a_dim1], &c__1, &c1, &s1); + i__2 = k2 - istartm + 1; + srot_(&i__2, &b[istartm + (k2 + 1) * b_dim1], &c__1, &b[ + istartm + k2 * b_dim1], &c__1, &c1, &s1); + srot_(&jw, &zc[(k2 + 1 - kwtop + 1) * zc_dim1 + 1], &c__1, + &zc[(k2 - kwtop + 1) * zc_dim1 + 1], &c__1, &c1, + &s1); + slartg_(&a[k2 + 1 + k2 * a_dim1], &a[k2 + 2 + k2 * a_dim1] + , &c1, &s1, &temp); + a[k2 + 1 + k2 * a_dim1] = temp; + a[k2 + 2 + k2 * a_dim1] = 0.f; + i__2 = istopm - k2; + srot_(&i__2, &a[k2 + 1 + (k2 + 1) * a_dim1], lda, &a[k2 + + 2 + (k2 + 1) * a_dim1], lda, &c1, &s1); + i__2 = istopm - k2; + srot_(&i__2, &b[k2 + 1 + (k2 + 1) * b_dim1], ldb, &b[k2 + + 2 + (k2 + 1) * b_dim1], ldb, &c1, &s1); + srot_(&jw, &qc[(k2 + 1 - kwtop + 1) * qc_dim1 + 1], &c__1, + &qc[(k2 + 2 - kwtop + 1) * qc_dim1 + 1], &c__1, & + c1, &s1); + } +/* Remove the shift */ + slartg_(&b[kwbot + kwbot * b_dim1], &b[kwbot + (kwbot - 1) * + b_dim1], &c1, &s1, &temp); + b[kwbot + kwbot * b_dim1] = temp; + b[kwbot + (kwbot - 1) * b_dim1] = 0.f; + i__1 = kwbot - istartm; + srot_(&i__1, &b[istartm + kwbot * b_dim1], &c__1, &b[istartm + + (kwbot - 1) * b_dim1], &c__1, &c1, &s1); + i__1 = kwbot - istartm + 1; + srot_(&i__1, &a[istartm + kwbot * a_dim1], &c__1, &a[istartm + + (kwbot - 1) * a_dim1], &c__1, &c1, &s1); + srot_(&jw, &zc[(kwbot - kwtop + 1) * zc_dim1 + 1], &c__1, &zc[ + (kwbot - 1 - kwtop + 1) * zc_dim1 + 1], &c__1, &c1, & + s1); + --k; + } + } + } +/* Apply Qc and Zc to rest of the matrix */ + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } + if (istopm - *ihi > 0) { + i__1 = istopm - *ihi; + sgemm_("T", "N", &jw, &i__1, &jw, &c_b17, &qc[qc_offset], ldqc, &a[ + kwtop + (*ihi + 1) * a_dim1], lda, &c_b16, &work[1], &jw); + i__1 = istopm - *ihi; + slacpy_("ALL", &jw, &i__1, &work[1], &jw, &a[kwtop + (*ihi + 1) * + a_dim1], lda); + i__1 = istopm - *ihi; + sgemm_("T", "N", &jw, &i__1, &jw, &c_b17, &qc[qc_offset], ldqc, &b[ + kwtop + (*ihi + 1) * b_dim1], ldb, &c_b16, &work[1], &jw); + i__1 = istopm - *ihi; + slacpy_("ALL", &jw, &i__1, &work[1], &jw, &b[kwtop + (*ihi + 1) * + b_dim1], ldb); + } + if (*ilq) { + sgemm_("N", "N", n, &jw, &jw, &c_b17, &q[kwtop * q_dim1 + 1], ldq, & + qc[qc_offset], ldqc, &c_b16, &work[1], n); + slacpy_("ALL", n, &jw, &work[1], n, &q[kwtop * q_dim1 + 1], ldq); + } + if (kwtop - 1 - istartm + 1 > 0) { + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + sgemm_("N", "N", &i__1, &jw, &jw, &c_b17, &a[istartm + kwtop * a_dim1] + , lda, &zc[zc_offset], ldzc, &c_b16, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + slacpy_("ALL", &i__1, &jw, &work[1], &i__2, &a[istartm + kwtop * + a_dim1], lda); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + sgemm_("N", "N", &i__1, &jw, &jw, &c_b17, &b[istartm + kwtop * b_dim1] + , ldb, &zc[zc_offset], ldzc, &c_b16, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + slacpy_("ALL", &i__1, &jw, &work[1], &i__2, &b[istartm + kwtop * + b_dim1], ldb); + } + if (*ilz) { + sgemm_("N", "N", n, &jw, &jw, &c_b17, &z__[kwtop * z_dim1 + 1], ldz, & + zc[zc_offset], ldzc, &c_b16, &work[1], n); + slacpy_("ALL", n, &jw, &work[1], n, &z__[kwtop * z_dim1 + 1], ldz); + } + return; +} /* slaqz3_ */ + diff --git a/lapack-netlib/SRC/slaqz4.c b/lapack-netlib/SRC/slaqz4.c index 7856e080ff..83f8ef5cf3 100644 --- a/lapack-netlib/SRC/slaqz4.c +++ b/lapack-netlib/SRC/slaqz4.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,8 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#define pCf(z) (*_pCf(z)) -#define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -189,28 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -232,171 +204,411 @@ typedef struct Namelist Namelist; #define i_len(s, n) (n) #define i_nint(x) ((integer)u_nint(*(x))) #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) -#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) -#define pow_si(B,E) spow_ui(*(B),*(E)) -#define pow_ri(B,E) spow_ui(*(B),*(E)) -#define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; -#define z_abs(z) (cabs(Cd(z))) -#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} -#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } + +/* Table of constant values */ + +static real c_b4 = 0.f; +static real c_b5 = 1.f; +static integer c__1 = 1; +static logical c_true = TRUE_; + +/* Subroutine */ void slaqz4_(logical *ilschur, logical *ilq, logical *ilz, + integer *n, integer *ilo, integer *ihi, integer *nshifts, integer * + nblock_desired__, real *sr, real *si, real *ss, real *a, integer *lda, + real *b, integer *ldb, real *q, integer *ldq, real *z__, integer * + ldz, real *qc, integer *ldqc, real *zc, integer *ldzc, real *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, qc_dim1, qc_offset, zc_dim1, zc_offset, i__1, i__2, + i__3, i__4, i__5; + + /* Local variables */ + static integer i__, j, k; + static real v[3], c1, c2, s1, s2; + static integer np, ns; + static real temp, swap; + static integer npos; + extern /* Subroutine */ void srot_(integer *, real *, integer *, real *, + integer *, real *, real *), sgemm_(char *, char *, integer *, + integer *, integer *, real *, real *, integer *, real *, integer * + , real *, real *, integer * /*, ftnlen, ftnlen*/), slaqz1_(real *, + integer *, real *, integer *, real *, real *, real *, real *, + real *, real *), slaqz2_(logical *, logical *, integer *, integer + *, integer *, integer *, real *, integer *, real *, integer *, + integer *, integer *, real *, integer *, integer *, integer *, + real *, integer *); + static integer nblock; + extern /* Subroutine */ void xerbla_(char *, integer * /*, ftnlen*/); + static integer ishift; + extern /* Subroutine */ void slaset_(char *, integer *, integer *, real *, + real *, real *, integer * /*, ftnlen*/), slartg_(real *, real *, real * + , real *, real *), slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer * /*, ftnlen*/); + static integer istopb, swidth, istopm, sheight; + extern real sroundup_lwork__(integer *); + static integer istartb, istartm; + +/* Function arguments */ +/* Parameters */ +/* Local scalars */ + +/* External functions */ + /* Parameter adjustments */ + --sr; + --si; + --ss; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + qc_dim1 = *ldqc; + qc_offset = 1 + qc_dim1; + qc -= qc_offset; + zc_dim1 = *ldzc; + zc_offset = 1 + zc_dim1; + zc -= zc_offset; + --work; + + /* Function Body */ + *info = 0; + if (*nblock_desired__ < *nshifts + 1) { + *info = -8; + } + if (*lwork == -1) { +/* workspace query, quick return */ + i__1 = *n * *nblock_desired__; + work[1] = sroundup_lwork__(&i__1); + return; + } else if (*lwork < *n * *nblock_desired__) { + *info = -25; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAQZ4", &i__1 /*, (ftnlen)6*/); + return; + } +/* Executable statements */ + if (*nshifts < 2) { + return; + } + if (*ilo >= *ihi) { + return; + } + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } +/* Shuffle shifts into pairs of real shifts and pairs */ +/* of complex conjugate shifts assuming complex */ +/* conjugate shifts are already adjacent to one */ +/* another */ + i__1 = *nshifts - 2; + for (i__ = 1; i__ <= i__1; i__ += 2) { + if (si[i__] != -si[i__ + 1]) { + + swap = sr[i__]; + sr[i__] = sr[i__ + 1]; + sr[i__ + 1] = sr[i__ + 2]; + sr[i__ + 2] = swap; + swap = si[i__]; + si[i__] = si[i__ + 1]; + si[i__ + 1] = si[i__ + 2]; + si[i__ + 2] = swap; + swap = ss[i__]; + ss[i__] = ss[i__ + 1]; + ss[i__ + 1] = ss[i__ + 2]; + ss[i__ + 2] = swap; } - return pow; -} -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } + } +/* NSHFTS is supposed to be even, but if it is odd, */ +/* then simply reduce it by one. The shuffle above */ +/* ensures that the dropped shift is real and that */ +/* the remaining shifts are paired. */ + ns = *nshifts - *nshifts % 2; +/* Computing MAX */ + i__1 = *nblock_desired__ - ns; + npos = f2cmax(i__1,1); +/* The following block introduces the shifts and chases */ +/* them down one by one just enough to make space for */ +/* the other shifts. The near-the-diagonal block is */ +/* of size (ns+1) x ns. */ + i__1 = ns + 1; + i__2 = ns + 1; + slaset_("FULL", &i__1, &i__2, &c_b4, &c_b5, &qc[qc_offset], ldqc /*, (ftnlen)4*/); + slaset_("FULL", &ns, &ns, &c_b4, &c_b5, &zc[zc_offset], ldzc /*, (ftnlen)4*/); + i__1 = ns; + for (i__ = 1; i__ <= i__1; i__ += 2) { +/* Introduce the shift */ + slaqz1_(&a[*ilo + *ilo * a_dim1], lda, &b[*ilo + *ilo * b_dim1], ldb, + &sr[i__], &sr[i__ + 1], &si[i__], &ss[i__], &ss[i__ + 1], v); + temp = v[1]; + slartg_(&temp, &v[2], &c1, &s1, &v[1]); + slartg_(v, &v[1], &c2, &s2, &temp); + srot_(&ns, &a[*ilo + 1 + *ilo * a_dim1], lda, &a[*ilo + 2 + *ilo * + a_dim1], lda, &c1, &s1); + srot_(&ns, &a[*ilo + *ilo * a_dim1], lda, &a[*ilo + 1 + *ilo * a_dim1] + , lda, &c2, &s2); + srot_(&ns, &b[*ilo + 1 + *ilo * b_dim1], ldb, &b[*ilo + 2 + *ilo * + b_dim1], ldb, &c1, &s1); + srot_(&ns, &b[*ilo + *ilo * b_dim1], ldb, &b[*ilo + 1 + *ilo * b_dim1] + , ldb, &c2, &s2); + i__2 = ns + 1; + srot_(&i__2, &qc[(qc_dim1 << 1) + 1], &c__1, &qc[qc_dim1 * 3 + 1], & + c__1, &c1, &s1); + i__2 = ns + 1; + srot_(&i__2, &qc[qc_dim1 + 1], &c__1, &qc[(qc_dim1 << 1) + 1], &c__1, + &c2, &s2); +/* Chase the shift down */ + i__2 = ns - 1 - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = *ihi - *ilo + 1; + i__4 = ns + 1; + slaqz2_(&c_true, &c_true, &j, &c__1, &ns, &i__3, &a[*ilo + *ilo * + a_dim1], lda, &b[*ilo + *ilo * b_dim1], ldb, &i__4, &c__1, + &qc[qc_offset], ldqc, &ns, &c__1, &zc[zc_offset], ldzc); } - return pow; -} -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; + } +/* Update the rest of the pencil */ +/* Update A(ilo:ilo+ns,ilo+ns:istopm) and B(ilo:ilo+ns,ilo+ns:istopm) */ +/* from the left with Qc(1:ns+1,1:ns+1)' */ + sheight = ns + 1; + swidth = istopm - (*ilo + ns) + 1; + if (swidth > 0) { + sgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &a[*ilo + (*ilo + ns) * a_dim1], lda, &c_b4, &work[1], & + sheight/*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ilo + (*ilo + + ns) * a_dim1], lda/*, (ftnlen)3*/); + sgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &b[*ilo + (*ilo + ns) * b_dim1], ldb, &c_b4, &work[1], & + sheight/*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ilo + (*ilo + + ns) * b_dim1], ldb/*, (ftnlen)3*/); + } + if (*ilq) { + sgemm_("N", "N", n, &sheight, &sheight, &c_b5, &q[*ilo * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b4, &work[1], n/*, (ftnlen)1, ( + ftnlen)1*/); + slacpy_("ALL", n, &sheight, &work[1], n, &q[*ilo * q_dim1 + 1], ldq/*, ( + ftnlen)3*/); + } +/* Update A(istartm:ilo-1,ilo:ilo+ns-1) and B(istartm:ilo-1,ilo:ilo+ns-1) */ +/* from the right with Zc(1:ns,1:ns) */ + sheight = *ilo - 1 - istartm + 1; + swidth = ns; + if (sheight > 0) { + sgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &a[istartm + *ilo + * a_dim1], lda, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight/*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + * + ilo * a_dim1], lda/*, (ftnlen)3*/); + sgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &b[istartm + *ilo + * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight/*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + * + ilo * b_dim1], ldb/*, (ftnlen)3*/); + } + if (*ilz) { + sgemm_("N", "N", n, &swidth, &swidth, &c_b5, &z__[*ilo * z_dim1 + 1], + ldz, &zc[zc_offset], ldzc, &c_b4, &work[1], n/*, (ftnlen)1, ( + ftnlen)1*/); + slacpy_("ALL", n, &swidth, &work[1], n, &z__[*ilo * z_dim1 + 1], ldz + /*, (ftnlen)3*/); + } +/* The following block chases the shifts down to the bottom */ +/* right block. If possible, a shift is moved down npos */ +/* positions at a time */ + k = *ilo; + while(k < *ihi - ns) { +/* Computing MIN */ + i__1 = *ihi - ns - k; + np = f2cmin(i__1,npos); +/* Size of the near-the-diagonal block */ + nblock = ns + np; +/* istartb points to the first row we will be updating */ + istartb = k + 1; +/* istopb points to the last column we will be updating */ + istopb = k + nblock - 1; + i__1 = ns + np; + i__2 = ns + np; + slaset_("FULL", &i__1, &i__2, &c_b4, &c_b5, &qc[qc_offset], ldqc + /*, (ftnlen)4*/); + i__1 = ns + np; + i__2 = ns + np; + slaset_("FULL", &i__1, &i__2, &c_b4, &c_b5, &zc[zc_offset], ldzc + /*, (ftnlen)4*/); +/* Near the diagonal shift chase */ + for (i__ = ns - 1; i__ >= 0; i__ += -2) { + i__1 = np - 1; + for (j = 0; j <= i__1; ++j) { +/* Move down the block with index k+i+j-1, updating */ +/* the (ns+np x ns+np) block: */ +/* (k:k+ns+np,k:k+ns+np-1) */ + i__2 = k + i__ + j - 1; + i__3 = k + 1; + slaqz2_(&c_true, &c_true, &i__2, &istartb, &istopb, ihi, &a[ + a_offset], lda, &b[b_offset], ldb, &nblock, &i__3, & + qc[qc_offset], ldqc, &nblock, &k, &zc[zc_offset], + ldzc); + } } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } +/* Update rest of the pencil */ +/* Update A(k+1:k+ns+np, k+ns+np:istopm) and */ +/* B(k+1:k+ns+np, k+ns+np:istopm) */ +/* from the left with Qc(1:ns+np,1:ns+np)' */ + sheight = ns + np; + swidth = istopm - (k + ns + np) + 1; + if (swidth > 0) { + sgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[ + qc_offset], ldqc, &a[k + 1 + (k + ns + np) * a_dim1], lda, + &c_b4, &work[1], &sheight /*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[k + 1 + ( + k + ns + np) * a_dim1], lda /*, (ftnlen)3*/); + sgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[ + qc_offset], ldqc, &b[k + 1 + (k + ns + np) * b_dim1], ldb, + &c_b4, &work[1], &sheight/*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[k + 1 + ( + k + ns + np) * b_dim1], ldb/*, (ftnlen)3*/); } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex float zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i 0) { + sgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &a[istartm + + k * a_dim1], lda, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight /*, (ftnlen)1, (ftnlen)1*/ ); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + + k * a_dim1], lda /*, (ftnlen)3 */); + sgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &b[istartm + + k * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b4, &work[1], & + sheight /*, (ftnlen)1, (ftnlen)1*/ ); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + + k * b_dim1], ldb /*, (ftnlen)3*/ ); } - pCd(z) = zdotc; -} -static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex float zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i 0) { + sgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &a[*ihi - ns + 1 + (*ihi + 1) * a_dim1], lda, &c_b4, & + work[1], &sheight /*, (ftnlen)1, (ftnlen)1*/ ); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ihi - ns + + 1 + (*ihi + 1) * a_dim1], lda /*, (ftnlen)3*/); + sgemm_("T", "N", &sheight, &swidth, &sheight, &c_b5, &qc[qc_offset], + ldqc, &b[*ihi - ns + 1 + (*ihi + 1) * b_dim1], ldb, &c_b4, & + work[1], &sheight /*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ihi - ns + + 1 + (*ihi + 1) * b_dim1], ldb /*, (ftnlen)3*/); + } + if (*ilq) { + sgemm_("N", "N", n, &ns, &ns, &c_b5, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b4, &work[1], n + /* , (ftnlen)1, (ftnlen)1 */ ); + slacpy_("ALL", n, &ns, &work[1], n, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq /*, (ftnlen)3*/ ); + } +/* Update A(istartm:ihi-ns,ihi-ns:ihi) */ +/* from the right with Zc(1:ns+1,1:ns+1) */ + sheight = *ihi - ns - istartm + 1; + swidth = ns + 1; + if (sheight > 0) { + sgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &a[istartm + (* + ihi - ns) * a_dim1], lda, &zc[zc_offset], ldzc, &c_b4, &work[ + 1], &sheight /*, (ftnlen)1, (ftnlen)1*/ ); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + (* + ihi - ns) * a_dim1], lda /*, (ftnlen)3*/); + sgemm_("N", "N", &sheight, &swidth, &swidth, &c_b5, &b[istartm + (* + ihi - ns) * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b4, &work[ + 1], &sheight /*, (ftnlen)1, (ftnlen)1*/); + slacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + (* + ihi - ns) * b_dim1], ldb /*, (ftnlen)3*/); + } + if (*ilz) { + i__1 = ns + 1; + i__2 = ns + 1; + sgemm_("N", "N", n, &i__1, &i__2, &c_b5, &z__[(*ihi - ns) * z_dim1 + + 1], ldz, &zc[zc_offset], ldzc, &c_b4, &work[1], n + /* , (ftnlen)1, (ftnlen)1*/ ); + i__1 = ns + 1; + slacpy_("ALL", n, &i__1, &work[1], n, &z__[(*ihi - ns) * z_dim1 + 1], + ldz /* , (ftnlen)3*/ ); + } + return; +} /* slaqz4_ */ + diff --git a/lapack-netlib/SRC/zlaqz0.c b/lapack-netlib/SRC/zlaqz0.c index 7856e080ff..2ab0530576 100644 --- a/lapack-netlib/SRC/zlaqz0.c +++ b/lapack-netlib/SRC/zlaqz0.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -191,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -204,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -244,26 +247,25 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +290,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +317,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +345,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +379,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *n || *ihi < *ilo - 1) { + *info = -6; + } else if (*lda < *n) { + *info = -8; + } else if (*ldb < *n) { + *info = -10; + } else if (*ldq < 1 || (ilq && *ldq < *n)) { + *info = -15; + } else if (*ldz < 1 || (ilz && *ldz < *n)) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAQZ0", &i__1); + return; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1].r = 1., work[1].i = 0.; + return; + } + +/* Get the parameters */ + + *(unsigned char *)jbcmpz = *(unsigned char *)wants; + *(unsigned char *)&jbcmpz[1] = *(unsigned char *)wantq; + *(unsigned char *)&jbcmpz[2] = *(unsigned char *)wantz; + nmin = ilaenv_(&c__12, "ZLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = ilaenv_(&c__13, "ZLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + nibble = ilaenv_(&c__14, "ZLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)3); + nsr = ilaenv_(&c__15, "ZLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - * + ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + rcost = ilaenv_(&c__17, "ZLAQZ0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, ( + ftnlen)3); + itemp1 = (integer) (nsr / sqrt((nsr << 1) / ((doublereal) rcost / 100 * * + n) + 1)); + itemp1 = ((itemp1 - 1) / 4 << 2) + 4; + nbr = nsr + itemp1; + if (*n < nmin || *rec >= 2) { + zhgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alpha[1], &beta[1], &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], lwork, &rwork[1], info); + return; + } + +/* Find out required workspace */ + +/* Workspace query to ZLAQZ2 */ + nw = f2cmax(nwr,nmin); + zlaqz2_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nw, &a[a_offset], lda, &b[ + b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + n_undeflated__, &n_deflated__, &alpha[1], &beta[1], &work[1], &nw, + &work[1], &nw, &work[1], &c_n1, &rwork[1], rec, &aed_info__); + itemp1 = (integer) work[1].r; +/* Workspace query to ZLAQZ3 */ + zlaqz3_(&ilschur, &ilq, &ilz, n, ilo, ihi, &nsr, &nbr, &alpha[1], &beta[1] + , &a[a_offset], lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[ + z_offset], ldz, &work[1], &nbr, &work[1], &nbr, &work[1], &c_n1, & + sweep_info__); + itemp2 = (integer) work[1].r; +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__4 = nbr; + i__1 = itemp1 + (i__3 * i__3 << 1), i__2 = itemp2 + (i__4 * i__4 << 1); + lworkreq = f2cmax(i__1,i__2); + if (*lwork == -1) { + d__1 = (doublereal) lworkreq; + work[1].r = d__1, work[1].i = 0.; + return; + } else if (*lwork < lworkreq) { + *info = -18; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAQZ0", &i__1); + return; + } + +/* Initialize Q and Z */ + + if (iwantq == 3) { + zlaset_("FULL", n, n, &c_b1, &c_b2, &q[q_offset], ldq); + } + if (iwantz == 3) { + zlaset_("FULL", n, n, &c_b1, &c_b2, &z__[z_offset], ldz); + } +/* Get machine constants */ + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) (*n) / ulp); + i__1 = *ihi - *ilo + 1; + bnorm = zlanhs_("F", &i__1, &b[*ilo + *ilo * b_dim1], ldb, &rwork[1]); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * bnorm; + btol = f2cmax(d__1,d__2); + istart = *ilo; + istop = *ihi; + maxit = (*ihi - *ilo + 1) * 30; + ld = 0; + i__1 = maxit; + for (iiter = 1; iiter <= i__1; ++iiter) { + if (iiter >= maxit) { + *info = istop + 1; + goto L80; + } + if (istart + 1 >= istop) { + istop = istart; + myexit_(); + } +/* Check deflations at the end */ +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * (z_abs(&a[istop + istop * a_dim1]) + + z_abs(&a[istop - 1 + (istop - 1) * a_dim1])); + if (z_abs(&a[istop + (istop - 1) * a_dim1]) <= f2cmax(d__1,d__2)) { + i__2 = istop + (istop - 1) * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + --istop; + ld = 0; + eshift.r = 0., eshift.i = 0.; + } +/* Check deflations at the start */ +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * (z_abs(&a[istart + istart * a_dim1]) + + z_abs(&a[istart + 1 + (istart + 1) * a_dim1])); + if (z_abs(&a[istart + 1 + istart * a_dim1]) <= f2cmax(d__1,d__2)) { + i__2 = istart + 1 + istart * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + ++istart; + ld = 0; + eshift.r = 0., eshift.i = 0.; + } + if (istart + 1 >= istop) { + myexit_(); + } +/* Check interior deflations */ + istart2 = istart; + i__2 = istart + 1; + for (k = istop; k >= i__2; --k) { +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * (z_abs(&a[k + k * a_dim1]) + z_abs(&a[ + k - 1 + (k - 1) * a_dim1])); + if (z_abs(&a[k + (k - 1) * a_dim1]) <= f2cmax(d__1,d__2)) { + i__3 = k + (k - 1) * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + istart2 = k; + myexit_(); + } + } +/* Get range to apply rotations to */ + if (ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = istart2; + istopm = istop; + } +/* Check infinite eigenvalues, this is done without blocking so might */ +/* slow down the method when many infinite eigenvalues are present */ + k = istop; + while(k >= istart2) { + if (z_abs(&b[k + k * b_dim1]) < btol) { +/* A diagonal element of B is negligible, move it */ +/* to the top and deflate it */ + i__2 = istart2 + 1; + for (k2 = k; k2 >= i__2; --k2) { + zlartg_(&b[k2 - 1 + k2 * b_dim1], &b[k2 - 1 + (k2 - 1) * + b_dim1], &c1, &s1, &temp); + i__3 = k2 - 1 + k2 * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; + i__3 = k2 - 1 + (k2 - 1) * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; + i__3 = k2 - 2 - istartm + 1; + zrot_(&i__3, &b[istartm + k2 * b_dim1], &c__1, &b[istartm + + (k2 - 1) * b_dim1], &c__1, &c1, &s1); +/* Computing MIN */ + i__4 = k2 + 1; + i__3 = f2cmin(i__4,istop) - istartm + 1; + zrot_(&i__3, &a[istartm + k2 * a_dim1], &c__1, &a[istartm + + (k2 - 1) * a_dim1], &c__1, &c1, &s1); + if (ilz) { + zrot_(n, &z__[k2 * z_dim1 + 1], &c__1, &z__[(k2 - 1) * + z_dim1 + 1], &c__1, &c1, &s1); + } + if (k2 < istop) { + zlartg_(&a[k2 + (k2 - 1) * a_dim1], &a[k2 + 1 + (k2 - + 1) * a_dim1], &c1, &s1, &temp); + i__3 = k2 + (k2 - 1) * a_dim1; + a[i__3].r = temp.r, a[i__3].i = temp.i; + i__3 = k2 + 1 + (k2 - 1) * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + i__3 = istopm - k2 + 1; + zrot_(&i__3, &a[k2 + k2 * a_dim1], lda, &a[k2 + 1 + + k2 * a_dim1], lda, &c1, &s1); + i__3 = istopm - k2 + 1; + zrot_(&i__3, &b[k2 + k2 * b_dim1], ldb, &b[k2 + 1 + + k2 * b_dim1], ldb, &c1, &s1); + if (ilq) { + d_cnjg(&z__1, &s1); + zrot_(n, &q[k2 * q_dim1 + 1], &c__1, &q[(k2 + 1) * + q_dim1 + 1], &c__1, &c1, &z__1); + } + } + } + if (istart2 < istop) { + zlartg_(&a[istart2 + istart2 * a_dim1], &a[istart2 + 1 + + istart2 * a_dim1], &c1, &s1, &temp); + i__2 = istart2 + istart2 * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + i__2 = istart2 + 1 + istart2 * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + i__2 = istopm - (istart2 + 1) + 1; + zrot_(&i__2, &a[istart2 + (istart2 + 1) * a_dim1], lda, & + a[istart2 + 1 + (istart2 + 1) * a_dim1], lda, &c1, + &s1); + i__2 = istopm - (istart2 + 1) + 1; + zrot_(&i__2, &b[istart2 + (istart2 + 1) * b_dim1], ldb, & + b[istart2 + 1 + (istart2 + 1) * b_dim1], ldb, &c1, + &s1); + if (ilq) { + d_cnjg(&z__1, &s1); + zrot_(n, &q[istart2 * q_dim1 + 1], &c__1, &q[(istart2 + + 1) * q_dim1 + 1], &c__1, &c1, &z__1); + } + } + ++istart2; + } + --k; + } +/* istart2 now points to the top of the bottom right */ +/* unreduced Hessenberg block */ + if (istart2 >= istop) { + istop = istart2 - 1; + ld = 0; + eshift.r = 0., eshift.i = 0.; + mycycle_(); + } + nw = nwr; + nshifts = nsr; + nblock = nbr; + if (istop - istart2 + 1 < nmin) { +/* Setting nw to the size of the subblock will make AED deflate */ +/* all the eigenvalues. This is slightly more efficient than just */ +/* using qz_small because the off diagonal part gets updated via BLAS. */ + if (istop - istart + 1 < nmin) { + nw = istop - istart + 1; + istart2 = istart; + } else { + nw = istop - istart2 + 1; + } + } + +/* Time for AED */ + +/* Computing 2nd power */ + i__2 = nw; +/* Computing 2nd power */ + i__3 = nw; +/* Computing 2nd power */ + i__5 = nw; + i__4 = *lwork - (i__5 * i__5 << 1); + zlaqz2_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &nw, &a[a_offset], + lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], + ldz, &n_undeflated__, &n_deflated__, &alpha[1], &beta[1], & + work[1], &nw, &work[i__2 * i__2 + 1], &nw, &work[(i__3 * i__3 + << 1) + 1], &i__4, &rwork[1], rec, &aed_info__); + if (n_deflated__ > 0) { + istop -= n_deflated__; + ld = 0; + eshift.r = 0., eshift.i = 0.; + } + if (n_deflated__ * 100 > nibble * (n_deflated__ + n_undeflated__) || + istop - istart2 + 1 < nmin) { +/* AED has uncovered many eigenvalues. Skip a QZ sweep and run */ +/* AED again. */ + mycycle_(); + } + ++ld; +/* Computing MIN */ + i__2 = nshifts, i__3 = istop - istart2; + ns = f2cmin(i__2,i__3); + ns = f2cmin(ns,n_undeflated__); + shiftpos = istop - n_undeflated__ + 1; + if (ld % 6 == 0) { + +/* Exceptional shift. Chosen for no particularly good reason. */ + + if ((doublereal) maxit * safmin * z_abs(&a[istop + (istop - 1) * + a_dim1]) < z_abs(&a[istop - 1 + (istop - 1) * a_dim1])) { + z_div(&z__1, &a[istop + (istop - 1) * a_dim1], &b[istop - 1 + + (istop - 1) * b_dim1]); + eshift.r = z__1.r, eshift.i = z__1.i; + } else { + d__1 = safmin * (doublereal) maxit; + z__2.r = 1. / d__1, z__2.i = 0. / d__1; + z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i; + eshift.r = z__1.r, eshift.i = z__1.i; + } + i__2 = shiftpos; + alpha[i__2].r = 1., alpha[i__2].i = 0.; + i__2 = shiftpos; + beta[i__2].r = eshift.r, beta[i__2].i = eshift.i; + ns = 1; + } + +/* Time for a QZ sweep */ + +/* Computing 2nd power */ + i__2 = nblock; +/* Computing 2nd power */ + i__3 = nblock; +/* Computing 2nd power */ + i__5 = nblock; + i__4 = *lwork - (i__5 * i__5 << 1); + zlaqz3_(&ilschur, &ilq, &ilz, n, &istart2, &istop, &ns, &nblock, & + alpha[shiftpos], &beta[shiftpos], &a[a_offset], lda, &b[ + b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &work[ + 1], &nblock, &work[i__2 * i__2 + 1], &nblock, &work[(i__3 * + i__3 << 1) + 1], &i__4, &sweep_info__); + } + +/* Call ZHGEQZ to normalize the eigenvalue blocks and set the eigenvalues */ +/* If all the eigenvalues have been found, ZHGEQZ will not do any iterations */ +/* and only normalize the blocks. In case of a rare convergence failure, */ +/* the single shift might perform better. */ + +L80: + zhgeqz_(wants, wantq, wantz, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], + ldb, &alpha[1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldz, + &work[1], lwork, &rwork[1], &norm_info__); + *info = norm_info__; + return; +} /* zlaqz0_ */ + diff --git a/lapack-netlib/SRC/zlaqz1.c b/lapack-netlib/SRC/zlaqz1.c index 7856e080ff..4e2cdd9cbf 100644 --- a/lapack-netlib/SRC/zlaqz1.c +++ b/lapack-netlib/SRC/zlaqz1.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -191,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -204,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -244,26 +247,25 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +290,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +317,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +345,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +379,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i #include #include @@ -48,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -191,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -204,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -244,159 +247,393 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; + + +/* -- translated by f2c (version 20200916). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + + + +/* Table of constant values */ + +static doublecomplex c_b1 = {0.,0.}; +static doublecomplex c_b2 = {1.,0.}; +static integer c__1 = 1; +static integer c_n1 = -1; +static logical c_true = TRUE_; + +/* Subroutine */ void zlaqz2_(logical *ilschur, logical *ilq, logical *ilz, + integer *n, integer *ilo, integer *ihi, integer *nw, doublecomplex *a, + integer *lda, doublecomplex *b, integer *ldb, doublecomplex *q, + integer *ldq, doublecomplex *z__, integer *ldz, integer *ns, integer * + nd, doublecomplex *alpha, doublecomplex *beta, doublecomplex *qc, + integer *ldqc, doublecomplex *zc, integer *ldzc, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *rec, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, qc_dim1, qc_offset, zc_dim1, zc_offset, i__1, i__2, + i__3, i__4; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer lworkreq, k; + doublecomplex s; + doublereal c1; + integer k2; + doublecomplex s1; + integer jw, imk; + doublereal ulp; + integer ztgexc_info__, ifst; + doublecomplex temp; + integer ilst; + extern /* Subroutine */ void zrot_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublecomplex *), + zgemm_(char *, char *, integer *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer kwbot; + doublereal tempr; + doublecomplex mktmp; + integer kwtop, qz_small_info__; + extern /* Subroutine */ void zlaqz0_(char *, char *, char *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, integer *, integer *), + zlaqz1_(logical *, logical *, integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *, integer *, doublecomplex *, integer *, integer *, + integer *, doublecomplex *, integer *); + extern doublereal dlamch_(char *); + doublereal safmin; + extern /* Subroutine */ void xerbla_(char *, integer *); + doublereal safmax; + extern /* Subroutine */ void zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *), ztgexc_( + logical *, logical *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, integer *, integer *), + zlartg_(doublecomplex *, doublecomplex *, doublereal *, + doublecomplex *, doublecomplex *); + integer istopm; + doublereal smlnum; + integer istartm; + +/* Arguments */ +/* Parameters */ +/* Local Scalars */ +/* External Functions */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --alpha; + --beta; + qc_dim1 = *ldqc; + qc_offset = 1 + qc_dim1; + qc -= qc_offset; + zc_dim1 = *ldzc; + zc_offset = 1 + zc_dim1; + zc -= zc_offset; + --work; + --rwork; + + /* Function Body */ + *info = 0; +/* Set up deflation window */ +/* Computing MIN */ + i__1 = *nw, i__2 = *ihi - *ilo + 1; + jw = f2cmin(i__1,i__2); + kwtop = *ihi - jw + 1; + if (kwtop == *ilo) { + s.r = 0., s.i = 0.; + } else { + i__1 = kwtop + (kwtop - 1) * a_dim1; + s.r = a[i__1].r, s.i = a[i__1].i; + } +/* Determine required workspace */ + ifst = 1; + ilst = jw; + i__1 = *rec + 1; + zlaqz0_("S", "V", "V", &jw, &c__1, &jw, &a[kwtop + kwtop * a_dim1], lda, & + b[kwtop + kwtop * b_dim1], ldb, &alpha[1], &beta[1], &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &work[1], &c_n1, &rwork[1] + , &i__1, &qz_small_info__); +/* Computing 2nd power */ + i__1 = jw; + lworkreq = (integer) work[1].r + (i__1 * i__1 << 1); +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *nw; + i__1 = lworkreq, i__2 = *n * *nw, i__1 = f2cmax(i__1,i__2), i__2 = (i__3 * + i__3 << 1) + *n; + lworkreq = f2cmax(i__1,i__2); + if (*lwork == -1) { +/* workspace query, quick return */ + work[1].r = (doublereal) lworkreq, work[1].i = 0.; + return; + } else if (*lwork < lworkreq) { + *info = -25; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAQZ2", &i__1); + return; + } +/* Get machine constants */ + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) (*n) / ulp); + if (*ihi == kwtop) { +/* 1 by 1 deflation window, just try a regular deflation */ + i__1 = kwtop; + i__2 = kwtop + kwtop * a_dim1; + alpha[i__1].r = a[i__2].r, alpha[i__1].i = a[i__2].i; + i__1 = kwtop; + i__2 = kwtop + kwtop * b_dim1; + beta[i__1].r = b[i__2].r, beta[i__1].i = b[i__2].i; + *ns = 1; + *nd = 0; +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * z_abs(&a[kwtop + kwtop * a_dim1]); + if (z_abs(&s) <= f2cmax(d__1,d__2)) { + *ns = 0; + *nd = 1; + if (kwtop > *ilo) { + i__1 = kwtop + (kwtop - 1) * a_dim1; + a[i__1].r = 0., a[i__1].i = 0.; + } } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } + } +/* Store window in case of convergence failure */ + zlacpy_("ALL", &jw, &jw, &a[kwtop + kwtop * a_dim1], lda, &work[1], &jw); +/* Computing 2nd power */ + i__1 = jw; + zlacpy_("ALL", &jw, &jw, &b[kwtop + kwtop * b_dim1], ldb, &work[i__1 * + i__1 + 1], &jw); +/* Transform window to real schur form */ + zlaset_("FULL", &jw, &jw, &c_b1, &c_b2, &qc[qc_offset], ldqc); + zlaset_("FULL", &jw, &jw, &c_b1, &c_b2, &zc[zc_offset], ldzc); +/* Computing 2nd power */ + i__1 = jw; +/* Computing 2nd power */ + i__3 = jw; + i__2 = *lwork - (i__3 * i__3 << 1); + i__4 = *rec + 1; + zlaqz0_("S", "V", "V", &jw, &c__1, &jw, &a[kwtop + kwtop * a_dim1], lda, & + b[kwtop + kwtop * b_dim1], ldb, &alpha[1], &beta[1], &qc[ + qc_offset], ldqc, &zc[zc_offset], ldzc, &work[(i__1 * i__1 << 1) + + 1], &i__2, &rwork[1], &i__4, &qz_small_info__); + if (qz_small_info__ != 0) { +/* Convergence failure, restore the window and exit */ + *nd = 0; + *ns = jw - qz_small_info__; + zlacpy_("ALL", &jw, &jw, &work[1], &jw, &a[kwtop + kwtop * a_dim1], + lda); +/* Computing 2nd power */ + i__1 = jw; + zlacpy_("ALL", &jw, &jw, &work[i__1 * i__1 + 1], &jw, &b[kwtop + + kwtop * b_dim1], ldb); + return; + } +/* Deflation detection loop */ + if (kwtop == *ilo || (s.r == 0. && s.i == 0.)) { + kwbot = kwtop - 1; + } else { + kwbot = *ihi; + k = 1; + k2 = 1; + while(k <= jw) { +/* Try to deflate eigenvalue */ + tempr = z_abs(&a[kwbot + kwbot * a_dim1]); + if (tempr == 0.) { + tempr = z_abs(&s); + } + i__1 = (kwbot - kwtop + 1) * qc_dim1 + 1; + z__1.r = s.r * qc[i__1].r - s.i * qc[i__1].i, z__1.i = s.r * qc[ + i__1].i + s.i * qc[i__1].r; +/* Computing MAX */ + d__1 = ulp * tempr; + if (z_abs(&z__1) <= f2cmax(d__1,smlnum)) { +/* Deflatable */ + --kwbot; + } else { +/* Not deflatable, move out of the way */ + ifst = kwbot - kwtop + 1; + ilst = k2; + ztgexc_(&c_true, &c_true, &jw, &a[kwtop + kwtop * a_dim1], + lda, &b[kwtop + kwtop * b_dim1], ldb, &qc[qc_offset], + ldqc, &zc[zc_offset], ldzc, &ifst, &ilst, & + ztgexc_info__); + ++k2; + } + ++k; } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex float zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i= i__1; --k) { + zlartg_(&a[k + (kwtop - 1) * a_dim1], &a[k + 1 + (kwtop - 1) * + a_dim1], &c1, &s1, &temp); + i__2 = k + (kwtop - 1) * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; + i__2 = k + 1 + (kwtop - 1) * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; +/* Computing MAX */ + i__2 = kwtop, i__3 = k - 1; + k2 = f2cmax(i__2,i__3); + i__2 = *ihi - k2 + 1; + zrot_(&i__2, &a[k + k2 * a_dim1], lda, &a[k + 1 + k2 * a_dim1], + lda, &c1, &s1); + i__2 = *ihi - (k - 1) + 1; + zrot_(&i__2, &b[k + (k - 1) * b_dim1], ldb, &b[k + 1 + (k - 1) * + b_dim1], ldb, &c1, &s1); + d_cnjg(&z__1, &s1); + zrot_(&jw, &qc[(k - kwtop + 1) * qc_dim1 + 1], &c__1, &qc[(k + 1 + - kwtop + 1) * qc_dim1 + 1], &c__1, &c1, &z__1); } - pCf(z) = zdotc; -} -static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; - _Complex double zdotc = 0.0; - if (incx == 1 && incy == 1) { - for (i=0;i= kwtop) { +/* Move bulge down and remove it */ + i__1 = kwbot - 1; + for (k2 = k; k2 <= i__1; ++k2) { + i__2 = kwtop + jw - 1; + zlaqz1_(&c_true, &c_true, &k2, &kwtop, &i__2, &kwbot, &a[ + a_offset], lda, &b[b_offset], ldb, &jw, &kwtop, &qc[ + qc_offset], ldqc, &jw, &kwtop, &zc[zc_offset], ldzc); + } + --k; } - pCd(z) = zdotc; -} -#endif + } +/* Apply Qc and Zc to rest of the matrix */ + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } + if (istopm - *ihi > 0) { + i__1 = istopm - *ihi; + zgemm_("C", "N", &jw, &i__1, &jw, &c_b2, &qc[qc_offset], ldqc, &a[ + kwtop + (*ihi + 1) * a_dim1], lda, &c_b1, &work[1], &jw); + i__1 = istopm - *ihi; + zlacpy_("ALL", &jw, &i__1, &work[1], &jw, &a[kwtop + (*ihi + 1) * + a_dim1], lda); + i__1 = istopm - *ihi; + zgemm_("C", "N", &jw, &i__1, &jw, &c_b2, &qc[qc_offset], ldqc, &b[ + kwtop + (*ihi + 1) * b_dim1], ldb, &c_b1, &work[1], &jw); + i__1 = istopm - *ihi; + zlacpy_("ALL", &jw, &i__1, &work[1], &jw, &b[kwtop + (*ihi + 1) * + b_dim1], ldb); + } + if (*ilq) { + zgemm_("N", "N", n, &jw, &jw, &c_b2, &q[kwtop * q_dim1 + 1], ldq, &qc[ + qc_offset], ldqc, &c_b1, &work[1], n); + zlacpy_("ALL", n, &jw, &work[1], n, &q[kwtop * q_dim1 + 1], ldq); + } + if (kwtop - 1 - istartm + 1 > 0) { + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + zgemm_("N", "N", &i__1, &jw, &jw, &c_b2, &a[istartm + kwtop * a_dim1], + lda, &zc[zc_offset], ldzc, &c_b1, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + zlacpy_("ALL", &i__1, &jw, &work[1], &i__2, &a[istartm + kwtop * + a_dim1], lda); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + zgemm_("N", "N", &i__1, &jw, &jw, &c_b2, &b[istartm + kwtop * b_dim1], + ldb, &zc[zc_offset], ldzc, &c_b1, &work[1], &i__2); + i__1 = kwtop - istartm; + i__2 = kwtop - istartm; + zlacpy_("ALL", &i__1, &jw, &work[1], &i__2, &b[istartm + kwtop * + b_dim1], ldb); + } + if (*ilz) { + zgemm_("N", "N", n, &jw, &jw, &c_b2, &z__[kwtop * z_dim1 + 1], ldz, & + zc[zc_offset], ldzc, &c_b1, &work[1], n) + ; + zlacpy_("ALL", n, &jw, &work[1], n, &z__[kwtop * z_dim1 + 1], ldz); + } + return; +} /* zlaqz2_ */ + diff --git a/lapack-netlib/SRC/zlaqz3.c b/lapack-netlib/SRC/zlaqz3.c index 7856e080ff..9053a9161c 100644 --- a/lapack-netlib/SRC/zlaqz3.c +++ b/lapack-netlib/SRC/zlaqz3.c @@ -1,12 +1,3 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - #include #include #include @@ -48,14 +39,21 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif #define pCf(z) (*_pCf(z)) #define pCd(z) (*_pCd(z)) -typedef blasint logical; - +typedef int logical; +typedef short int shortlogical; typedef char logical1; typedef char integer1; @@ -191,8 +189,13 @@ typedef struct Namelist Namelist; #define abort_() { sig_die("Fortran abort routine called", 1); } #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} @@ -204,13 +207,13 @@ typedef struct Namelist Namelist; #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) #define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimag(Cf(z))) +#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -244,26 +247,25 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} -static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; #define mycycle_() continue; -#define myceiling_(w) ceil(w) -#define myhuge_(w) HUGE_VAL +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ - +#define F2C_proc_par_types 1 #ifdef __cplusplus typedef logical (*L_fp)(...); #else typedef logical (*L_fp)(); #endif - +#if 0 static float spow_ui(float x, integer n) { float pow=1.0; unsigned long int u; if(n != 0) { @@ -288,6 +290,21 @@ static double dpow_ui(double x, integer n) { } return pow; } +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else static _Complex float cpow_ui(_Complex float x, integer n) { _Complex float pow=1.0; unsigned long int u; if(n != 0) { @@ -300,6 +317,22 @@ static _Complex float cpow_ui(_Complex float x, integer n) { } return pow; } +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else static _Complex double zpow_ui(_Complex double x, integer n) { _Complex double pow=1.0; unsigned long int u; if(n != 0) { @@ -312,6 +345,7 @@ static _Complex double zpow_ui(_Complex double x, integer n) { } return pow; } +#endif static integer pow_ii(integer x, integer n) { integer pow; unsigned long int u; if (n <= 0) { @@ -345,6 +379,22 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) } static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= *ihi) { + return; + } + if (*ilschur) { + istartm = 1; + istopm = *n; + } else { + istartm = *ilo; + istopm = *ihi; + } + ns = *nshifts; +/* Computing MAX */ + i__1 = *nblock_desired__ - ns; + npos = f2cmax(i__1,1); +/* The following block introduces the shifts and chases */ +/* them down one by one just enough to make space for */ +/* the other shifts. The near-the-diagonal block is */ +/* of size (ns+1) x ns. */ + i__1 = ns + 1; + i__2 = ns + 1; + zlaset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &qc[qc_offset], ldqc); + zlaset_("FULL", &ns, &ns, &c_b1, &c_b2, &zc[zc_offset], ldzc); + i__1 = ns; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Introduce the shift */ + scale = sqrt(z_abs(&alpha[i__])) * sqrt(z_abs(&beta[i__])); + if (scale >= safmin && scale <= safmax) { + i__2 = i__; + i__3 = i__; + z__1.r = alpha[i__3].r / scale, z__1.i = alpha[i__3].i / scale; + alpha[i__2].r = z__1.r, alpha[i__2].i = z__1.i; + i__2 = i__; + i__3 = i__; + z__1.r = beta[i__3].r / scale, z__1.i = beta[i__3].i / scale; + beta[i__2].r = z__1.r, beta[i__2].i = z__1.i; + } + i__2 = i__; + i__3 = *ilo + *ilo * a_dim1; + z__2.r = beta[i__2].r * a[i__3].r - beta[i__2].i * a[i__3].i, z__2.i = + beta[i__2].r * a[i__3].i + beta[i__2].i * a[i__3].r; + i__4 = i__; + i__5 = *ilo + *ilo * b_dim1; + z__3.r = alpha[i__4].r * b[i__5].r - alpha[i__4].i * b[i__5].i, + z__3.i = alpha[i__4].r * b[i__5].i + alpha[i__4].i * b[i__5] + .r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = i__; + i__3 = *ilo + 1 + *ilo * a_dim1; + z__1.r = beta[i__2].r * a[i__3].r - beta[i__2].i * a[i__3].i, z__1.i = + beta[i__2].r * a[i__3].i + beta[i__2].i * a[i__3].r; + temp3.r = z__1.r, temp3.i = z__1.i; + if (z_abs(&temp2) > safmax || z_abs(&temp3) > safmax) { + temp2.r = 1., temp2.i = 0.; + temp3.r = 0., temp3.i = 0.; + } + zlartg_(&temp2, &temp3, &c__, &s, &temp); + zrot_(&ns, &a[*ilo + *ilo * a_dim1], lda, &a[*ilo + 1 + *ilo * a_dim1] + , lda, &c__, &s); + zrot_(&ns, &b[*ilo + *ilo * b_dim1], ldb, &b[*ilo + 1 + *ilo * b_dim1] + , ldb, &c__, &s); + i__2 = ns + 1; + d_cnjg(&z__1, &s); + zrot_(&i__2, &qc[qc_dim1 + 1], &c__1, &qc[(qc_dim1 << 1) + 1], &c__1, + &c__, &z__1); +/* Chase the shift down */ + i__2 = ns - i__; + for (j = 1; j <= i__2; ++j) { + i__3 = *ihi - *ilo + 1; + i__4 = ns + 1; + zlaqz1_(&c_true, &c_true, &j, &c__1, &ns, &i__3, &a[*ilo + *ilo * + a_dim1], lda, &b[*ilo + *ilo * b_dim1], ldb, &i__4, &c__1, + &qc[qc_offset], ldqc, &ns, &c__1, &zc[zc_offset], ldzc); + } + } +/* Update the rest of the pencil */ +/* Update A(ilo:ilo+ns,ilo+ns:istopm) and B(ilo:ilo+ns,ilo+ns:istopm) */ +/* from the left with Qc(1:ns+1,1:ns+1)' */ + sheight = ns + 1; + swidth = istopm - (*ilo + ns) + 1; + if (swidth > 0) { + zgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &a[*ilo + (*ilo + ns) * a_dim1], lda, &c_b1, &work[1], & + sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ilo + (*ilo + + ns) * a_dim1], lda); + zgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &b[*ilo + (*ilo + ns) * b_dim1], ldb, &c_b1, &work[1], & + sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ilo + (*ilo + + ns) * b_dim1], ldb); + } + if (*ilq) { + zgemm_("N", "N", n, &sheight, &sheight, &c_b2, &q[*ilo * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b1, &work[1], n); + zlacpy_("ALL", n, &sheight, &work[1], n, &q[*ilo * q_dim1 + 1], ldq); + } +/* Update A(istartm:ilo-1,ilo:ilo+ns-1) and B(istartm:ilo-1,ilo:ilo+ns-1) */ +/* from the right with Zc(1:ns,1:ns) */ + sheight = *ilo - 1 - istartm + 1; + swidth = ns; + if (sheight > 0) { + zgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &a[istartm + *ilo + * a_dim1], lda, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + * + ilo * a_dim1], lda); + zgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &b[istartm + *ilo + * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + * + ilo * b_dim1], ldb); + } + if (*ilz) { + zgemm_("N", "N", n, &swidth, &swidth, &c_b2, &z__[*ilo * z_dim1 + 1], + ldz, &zc[zc_offset], ldzc, &c_b1, &work[1], n); + zlacpy_("ALL", n, &swidth, &work[1], n, &z__[*ilo * z_dim1 + 1], ldz); + } +/* The following block chases the shifts down to the bottom */ +/* right block. If possible, a shift is moved down npos */ +/* positions at a time */ + k = *ilo; + while(k < *ihi - ns) { +/* Computing MIN */ + i__1 = *ihi - ns - k; + np = f2cmin(i__1,npos); +/* Size of the near-the-diagonal block */ + nblock = ns + np; +/* istartb points to the first row we will be updating */ + istartb = k + 1; +/* istopb points to the last column we will be updating */ + istopb = k + nblock - 1; + i__1 = ns + np; + i__2 = ns + np; + zlaset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &qc[qc_offset], ldqc); + i__1 = ns + np; + i__2 = ns + np; + zlaset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &zc[zc_offset], ldzc); +/* Near the diagonal shift chase */ + for (i__ = ns - 1; i__ >= 0; --i__) { + i__1 = np - 1; + for (j = 0; j <= i__1; ++j) { +/* Move down the block with index k+i+j, updating */ +/* the (ns+np x ns+np) block: */ +/* (k:k+ns+np,k:k+ns+np-1) */ + i__2 = k + i__ + j; + i__3 = k + 1; + zlaqz1_(&c_true, &c_true, &i__2, &istartb, &istopb, ihi, &a[ + a_offset], lda, &b[b_offset], ldb, &nblock, &i__3, & + qc[qc_offset], ldqc, &nblock, &k, &zc[zc_offset], + ldzc); + } + } +/* Update rest of the pencil */ +/* Update A(k+1:k+ns+np, k+ns+np:istopm) and */ +/* B(k+1:k+ns+np, k+ns+np:istopm) */ +/* from the left with Qc(1:ns+np,1:ns+np)' */ + sheight = ns + np; + swidth = istopm - (k + ns + np) + 1; + if (swidth > 0) { + zgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[ + qc_offset], ldqc, &a[k + 1 + (k + ns + np) * a_dim1], lda, + &c_b1, &work[1], &sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[k + 1 + ( + k + ns + np) * a_dim1], lda); + zgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[ + qc_offset], ldqc, &b[k + 1 + (k + ns + np) * b_dim1], ldb, + &c_b1, &work[1], &sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[k + 1 + ( + k + ns + np) * b_dim1], ldb); + } + if (*ilq) { + zgemm_("N", "N", n, &nblock, &nblock, &c_b2, &q[(k + 1) * q_dim1 + + 1], ldq, &qc[qc_offset], ldqc, &c_b1, &work[1], n); + zlacpy_("ALL", n, &nblock, &work[1], n, &q[(k + 1) * q_dim1 + 1], + ldq); + } +/* Update A(istartm:k,k:k+ns+npos-1) and B(istartm:k,k:k+ns+npos-1) */ +/* from the right with Zc(1:ns+np,1:ns+np) */ + sheight = k - istartm + 1; + swidth = nblock; + if (sheight > 0) { + zgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &a[istartm + + k * a_dim1], lda, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + + k * a_dim1], lda); + zgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &b[istartm + + k * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b1, &work[1], & + sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + + k * b_dim1], ldb); + } + if (*ilz) { + zgemm_("N", "N", n, &nblock, &nblock, &c_b2, &z__[k * z_dim1 + 1], + ldz, &zc[zc_offset], ldzc, &c_b1, &work[1], n); + zlacpy_("ALL", n, &nblock, &work[1], n, &z__[k * z_dim1 + 1], ldz); + } + k += np; + } +/* The following block removes the shifts from the bottom right corner */ +/* one by one. Updates are initially applied to A(ihi-ns+1:ihi,ihi-ns:ihi). */ + zlaset_("FULL", &ns, &ns, &c_b1, &c_b2, &qc[qc_offset], ldqc); + i__1 = ns + 1; + i__2 = ns + 1; + zlaset_("FULL", &i__1, &i__2, &c_b1, &c_b2, &zc[zc_offset], ldzc); +/* istartb points to the first row we will be updating */ + istartb = *ihi - ns + 1; +/* istopb points to the last column we will be updating */ + istopb = *ihi; + i__1 = ns; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Chase the shift down to the bottom right corner */ + i__2 = *ihi - 1; + for (ishift = *ihi - i__; ishift <= i__2; ++ishift) { + i__3 = *ihi - ns + 1; + i__4 = ns + 1; + i__5 = *ihi - ns; + zlaqz1_(&c_true, &c_true, &ishift, &istartb, &istopb, ihi, &a[ + a_offset], lda, &b[b_offset], ldb, &ns, &i__3, &qc[ + qc_offset], ldqc, &i__4, &i__5, &zc[zc_offset], ldzc); + } + } +/* Update rest of the pencil */ +/* Update A(ihi-ns+1:ihi, ihi+1:istopm) */ +/* from the left with Qc(1:ns,1:ns)' */ + sheight = ns; + swidth = istopm - (*ihi + 1) + 1; + if (swidth > 0) { + zgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &a[*ihi - ns + 1 + (*ihi + 1) * a_dim1], lda, &c_b1, & + work[1], &sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[*ihi - ns + + 1 + (*ihi + 1) * a_dim1], lda); + zgemm_("C", "N", &sheight, &swidth, &sheight, &c_b2, &qc[qc_offset], + ldqc, &b[*ihi - ns + 1 + (*ihi + 1) * b_dim1], ldb, &c_b1, & + work[1], &sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[*ihi - ns + + 1 + (*ihi + 1) * b_dim1], ldb); + } + if (*ilq) { + zgemm_("N", "N", n, &ns, &ns, &c_b2, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq, &qc[qc_offset], ldqc, &c_b1, &work[1], n); + zlacpy_("ALL", n, &ns, &work[1], n, &q[(*ihi - ns + 1) * q_dim1 + 1], + ldq); + } +/* Update A(istartm:ihi-ns,ihi-ns:ihi) */ +/* from the right with Zc(1:ns+1,1:ns+1) */ + sheight = *ihi - ns - istartm + 1; + swidth = ns + 1; + if (sheight > 0) { + zgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &a[istartm + (* + ihi - ns) * a_dim1], lda, &zc[zc_offset], ldzc, &c_b1, &work[ + 1], &sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &a[istartm + (* + ihi - ns) * a_dim1], lda); + zgemm_("N", "N", &sheight, &swidth, &swidth, &c_b2, &b[istartm + (* + ihi - ns) * b_dim1], ldb, &zc[zc_offset], ldzc, &c_b1, &work[ + 1], &sheight); + zlacpy_("ALL", &sheight, &swidth, &work[1], &sheight, &b[istartm + (* + ihi - ns) * b_dim1], ldb); + } + if (*ilz) { + i__1 = ns + 1; + i__2 = ns + 1; + zgemm_("N", "N", n, &i__1, &i__2, &c_b2, &z__[(*ihi - ns) * z_dim1 + + 1], ldz, &zc[zc_offset], ldzc, &c_b1, &work[1], n); + i__1 = ns + 1; + zlacpy_("ALL", n, &i__1, &work[1], n, &z__[(*ihi - ns) * z_dim1 + 1], + ldz); + } + return; +} /* zlaqz3_ */ +