|
- #include <math.h>
- #include <stdlib.h>
- #include <string.h>
- #include <stdio.h>
- #include <complex.h>
- #ifdef complex
- #undef complex
- #endif
- #ifdef I
- #undef I
- #endif
-
- #if defined(_WIN64)
- typedef long long BLASLONG;
- typedef unsigned long long BLASULONG;
- #else
- typedef long BLASLONG;
- typedef unsigned long BLASULONG;
- #endif
-
- #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 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;
- #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 int logical;
- typedef short int shortlogical;
- typedef char logical1;
- typedef char integer1;
-
- #define TRUE_ (1)
- #define FALSE_ (0)
-
- /* Extern is for use with -E */
- #ifndef Extern
- #define Extern extern
- #endif
-
- /* I/O stuff */
-
- typedef int flag;
- typedef int ftnlen;
- typedef int ftnint;
-
- /*external read, write*/
- typedef struct
- { flag cierr;
- ftnint ciunit;
- flag ciend;
- char *cifmt;
- ftnint cirec;
- } cilist;
-
- /*internal read, write*/
- typedef struct
- { flag icierr;
- char *iciunit;
- flag iciend;
- char *icifmt;
- ftnint icirlen;
- ftnint icirnum;
- } icilist;
-
- /*open*/
- typedef struct
- { flag oerr;
- ftnint ounit;
- char *ofnm;
- ftnlen ofnmlen;
- char *osta;
- char *oacc;
- char *ofm;
- ftnint orl;
- char *oblnk;
- } olist;
-
- /*close*/
- typedef struct
- { flag cerr;
- ftnint cunit;
- char *csta;
- } cllist;
-
- /*rewind, backspace, endfile*/
- typedef struct
- { flag aerr;
- ftnint aunit;
- } alist;
-
- /* inquire */
- typedef struct
- { flag inerr;
- ftnint inunit;
- char *infile;
- ftnlen infilen;
- ftnint *inex; /*parameters in standard's order*/
- ftnint *inopen;
- ftnint *innum;
- ftnint *innamed;
- char *inname;
- ftnlen innamlen;
- char *inacc;
- ftnlen inacclen;
- char *inseq;
- ftnlen inseqlen;
- char *indir;
- ftnlen indirlen;
- char *infmt;
- ftnlen infmtlen;
- char *inform;
- ftnint informlen;
- char *inunf;
- ftnlen inunflen;
- ftnint *inrecl;
- ftnint *innrec;
- char *inblank;
- ftnlen inblanklen;
- } inlist;
-
- #define VOID void
-
- union Multitype { /* for multiple entry points */
- integer1 g;
- shortint h;
- integer i;
- /* longint j; */
- real r;
- doublereal d;
- complex c;
- doublecomplex z;
- };
-
- typedef union Multitype Multitype;
-
- struct Vardesc { /* for Namelist */
- char *name;
- char *addr;
- ftnlen *dims;
- int type;
- };
- typedef struct Vardesc Vardesc;
-
- struct Namelist {
- char *name;
- Vardesc **vars;
- int nvars;
- };
- typedef struct Namelist Namelist;
-
- #define abs(x) ((x) >= 0 ? (x) : -(x))
- #define dabs(x) (fabs(x))
- #define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
- #define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
- #define dmin(a,b) (f2cmin(a,b))
- #define dmax(a,b) (f2cmax(a,b))
- #define bit_test(a,b) ((a) >> (b) & 1)
- #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
- #define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
-
- #define abort_() { 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));}
- //#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
- #define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
- #define d_abs(x) (fabs(*(x)))
- #define d_acos(x) (acos(*(x)))
- #define d_asin(x) (asin(*(x)))
- #define d_atan(x) (atan(*(x)))
- #define d_atn2(x, y) (atan2(*(x),*(y)))
- #define d_cnjg(R, Z) { pCd(R) = conj(Cd(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) (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)) )
- #define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
- #define d_log(x) (log(*(x)))
- #define d_mod(x, y) (fmod(*(x), *(y)))
- #define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
- #define d_nint(x) u_nint(*(x))
- #define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
- #define d_sign(a,b) u_sign(*(a),*(b))
- #define r_sign(a,b) u_sign(*(a),*(b))
- #define d_sin(x) (sin(*(x)))
- #define d_sinh(x) (sinh(*(x)))
- #define d_sqrt(x) (sqrt(*(x)))
- #define d_tan(x) (tan(*(x)))
- #define d_tanh(x) (tanh(*(x)))
- #define i_abs(x) abs(*(x))
- #define i_dnnt(x) ((integer)u_nint(*(x)))
- #define i_len(s, n) (n)
- #define i_nint(x) ((integer)u_nint(*(x)))
- #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
- #define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
- #define pow_si(B,E) spow_ui(*(B),*(E))
- #define pow_ri(B,E) spow_ui(*(B),*(E))
- #define pow_di(B,E) dpow_ui(*(B),*(E))
- #define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
- #define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
- #define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
- #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
- #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
- #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
- #define sig_die(s, kill) { exit(1); }
- #define s_stop(s, n) {exit(0);}
- static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
- #define z_abs(z) (cabs(Cd(z)))
- #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
- #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
- #define myexit_() break;
- #define mycycle_() continue;
- #define myceiling_(w) {ceil(w)}
- #define myhuge_(w) {HUGE_VAL}
- //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
- #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
-
- /* procedure parameter types for -A and -C++ */
-
- #define F2C_proc_par_types 1
- #ifdef __cplusplus
- typedef logical (*L_fp)(...);
- #else
- typedef logical (*L_fp)();
- #endif
-
- static float spow_ui(float x, integer n) {
- float pow=1.0; unsigned long int u;
- if(n != 0) {
- if(n < 0) n = -n, x = 1/x;
- for(u = n; ; ) {
- if(u & 01) pow *= x;
- if(u >>= 1) x *= x;
- else break;
- }
- }
- return pow;
- }
- static double dpow_ui(double x, integer n) {
- double pow=1.0; unsigned long int u;
- if(n != 0) {
- if(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;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
- zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
- zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
- }
- }
- pCf(z) = zdotc;
- }
- #else
- _Complex float zdotc = 0.0;
- if (incx == 1 && incy == 1) {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
- }
- }
- pCf(z) = zdotc;
- }
- #endif
- static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
- integer n = *n_, incx = *incx_, incy = *incy_, i;
- #ifdef _MSC_VER
- _Dcomplex zdotc = {0.0, 0.0};
- if (incx == 1 && incy == 1) {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
- zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
- zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
- }
- }
- pCd(z) = zdotc;
- }
- #else
- _Complex double zdotc = 0.0;
- if (incx == 1 && incy == 1) {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
- }
- }
- pCd(z) = zdotc;
- }
- #endif
- static inline void cdotu_(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;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
- zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
- zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
- }
- }
- pCf(z) = zdotc;
- }
- #else
- _Complex float zdotc = 0.0;
- if (incx == 1 && incy == 1) {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += Cf(&x[i]) * Cf(&y[i]);
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
- }
- }
- pCf(z) = zdotc;
- }
- #endif
- static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
- integer n = *n_, incx = *incx_, incy = *incy_, i;
- #ifdef _MSC_VER
- _Dcomplex zdotc = {0.0, 0.0};
- if (incx == 1 && incy == 1) {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
- zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
- zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
- }
- }
- pCd(z) = zdotc;
- }
- #else
- _Complex double zdotc = 0.0;
- if (incx == 1 && incy == 1) {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += Cd(&x[i]) * Cd(&y[i]);
- }
- } else {
- for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
- zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
- }
- }
- pCd(z) = zdotc;
- }
- #endif
- /* -- translated by f2c (version 20000121).
- You must link the resulting object file with the libraries:
- -lf2c -lm (in that order)
- */
-
-
-
- /* -- translated by f2c (version 20000121).
- You must link the resulting object file with the libraries:
- -lf2c -lm (in that order)
- */
-
-
-
- /* Table of constant values */
-
- static integer c__1 = 1;
- static real c_b179 = 0.f;
- static real c_b180 = 1.f;
- static integer c__0 = 0;
-
- /* > \brief \b ILAENV */
-
- /* =========== DOCUMENTATION =========== */
-
- /* Online html documentation available at */
- /* http://www.netlib.org/lapack/explore-html/ */
-
- /* > \htmlonly */
- /* > Download ILAENV + dependencies */
- /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaenv.
- f"> */
- /* > [TGZ]</a> */
- /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaenv.
- f"> */
- /* > [ZIP]</a> */
- /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaenv.
- f"> */
- /* > [TXT]</a> */
- /* > \endhtmlonly */
-
- /* Definition: */
- /* =========== */
-
- /* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) */
-
- /* CHARACTER*( * ) NAME, OPTS */
- /* INTEGER ISPEC, N1, N2, N3, N4 */
-
-
- /* > \par Purpose: */
- /* ============= */
- /* > */
- /* > \verbatim */
- /* > */
- /* > ILAENV is called from the LAPACK routines to choose problem-dependent */
- /* > parameters for the local environment. See ISPEC for a description of */
- /* > the parameters. */
- /* > */
- /* > ILAENV returns an INTEGER */
- /* > if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */
- /* > if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. */
- /* > */
- /* > This version provides a set of parameters which should give good, */
- /* > but not optimal, performance on many of the currently available */
- /* > computers. Users are encouraged to modify this subroutine to set */
- /* > the tuning parameters for their particular machine using the option */
- /* > and problem size information in the arguments. */
- /* > */
- /* > This routine will not function correctly if it is converted to all */
- /* > lower case. Converting it to all upper case is allowed. */
- /* > \endverbatim */
-
- /* Arguments: */
- /* ========== */
-
- /* > \param[in] ISPEC */
- /* > \verbatim */
- /* > ISPEC is INTEGER */
- /* > Specifies the parameter to be returned as the value of */
- /* > ILAENV. */
- /* > = 1: the optimal blocksize; if this value is 1, an unblocked */
- /* > algorithm will give the best performance. */
- /* > = 2: the minimum block size for which the block routine */
- /* > should be used; if the usable block size is less than */
- /* > this value, an unblocked routine should be used. */
- /* > = 3: the crossover point (in a block routine, for N less */
- /* > than this value, an unblocked routine should be used) */
- /* > = 4: the number of shifts, used in the nonsymmetric */
- /* > eigenvalue routines (DEPRECATED) */
- /* > = 5: the minimum column dimension for blocking to be used; */
- /* > rectangular blocks must have dimension at least k by m, */
- /* > where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
- /* > = 6: the crossover point for the SVD (when reducing an m by n */
- /* > matrix to bidiagonal form, if f2cmax(m,n)/f2cmin(m,n) exceeds */
- /* > this value, a QR factorization is used first to reduce */
- /* > the matrix to a triangular form.) */
- /* > = 7: the number of processors */
- /* > = 8: the crossover point for the multishift QR method */
- /* > for nonsymmetric eigenvalue problems (DEPRECATED) */
- /* > = 9: maximum size of the subproblems at the bottom of the */
- /* > computation tree in the divide-and-conquer algorithm */
- /* > (used by xGELSD and xGESDD) */
- /* > =10: ieee infinity and NaN arithmetic can be trusted not to trap */
- /* > =11: infinity arithmetic can be trusted not to trap */
- /* > 12 <= ISPEC <= 17: */
- /* > xHSEQR or related subroutines, */
- /* > see IPARMQ for detailed explanation */
- /* > \endverbatim */
- /* > */
- /* > \param[in] NAME */
- /* > \verbatim */
- /* > NAME is CHARACTER*(*) */
- /* > The name of the calling subroutine, in either upper case or */
- /* > lower case. */
- /* > \endverbatim */
- /* > */
- /* > \param[in] OPTS */
- /* > \verbatim */
- /* > OPTS is CHARACTER*(*) */
- /* > The character options to the subroutine NAME, concatenated */
- /* > into a single character string. For example, UPLO = 'U', */
- /* > TRANS = 'T', and DIAG = 'N' for a triangular routine would */
- /* > be specified as OPTS = 'UTN'. */
- /* > \endverbatim */
- /* > */
- /* > \param[in] N1 */
- /* > \verbatim */
- /* > N1 is INTEGER */
- /* > \endverbatim */
- /* > */
- /* > \param[in] N2 */
- /* > \verbatim */
- /* > N2 is INTEGER */
- /* > \endverbatim */
- /* > */
- /* > \param[in] N3 */
- /* > \verbatim */
- /* > N3 is INTEGER */
- /* > \endverbatim */
- /* > */
- /* > \param[in] N4 */
- /* > \verbatim */
- /* > N4 is INTEGER */
- /* > Problem dimensions for the subroutine NAME; these may not all */
- /* > be required. */
- /* > \endverbatim */
-
- /* Authors: */
- /* ======== */
-
- /* > \author Univ. of Tennessee */
- /* > \author Univ. of California Berkeley */
- /* > \author Univ. of Colorado Denver */
- /* > \author NAG Ltd. */
-
- /* > \ingroup ilaenv */
-
- /* > \par Further Details: */
- /* ===================== */
- /* > */
- /* > \verbatim */
- /* > */
- /* > The following conventions have been used when calling ILAENV from the */
- /* > LAPACK routines: */
- /* > 1) OPTS is a concatenation of all of the character options to */
- /* > subroutine NAME, in the same order that they appear in the */
- /* > argument list for NAME, even if they are not used in determining */
- /* > the value of the parameter specified by ISPEC. */
- /* > 2) The problem dimensions N1, N2, N3, N4 are specified in the order */
- /* > that they appear in the argument list for NAME. N1 is used */
- /* > first, N2 second, and so on, and unused problem dimensions are */
- /* > passed a value of -1. */
- /* > 3) The parameter value returned by ILAENV is checked for validity in */
- /* > the calling subroutine. For example, ILAENV is used to retrieve */
- /* > the optimal blocksize for STRTRI as follows: */
- /* > */
- /* > NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
- /* > IF( NB.LE.1 ) NB = MAX( 1, N ) */
- /* > \endverbatim */
- /* > */
- /* ===================================================================== */
- integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
- integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen
- opts_len)
- {
- /* System generated locals */
- integer ret_val, i__1, i__2, i__3;
-
- /* Local variables */
- logical twostage;
- integer i__;
- logical cname;
- integer nbmin;
- logical sname;
- char c1[1], c2[2], c3[3], c4[2];
- integer ic, nb;
- extern integer ieeeck_(integer *, real *, real *);
- integer iz, nx;
- char subnam[16];
- extern integer iparmq_(integer *, char *, char *, integer *, integer *,
- integer *, integer *);
-
-
- /* -- LAPACK auxiliary routine -- */
- /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
- /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
-
-
- /* ===================================================================== */
-
-
- switch (*ispec) {
- case 1: goto L10;
- case 2: goto L10;
- case 3: goto L10;
- case 4: goto L80;
- case 5: goto L90;
- case 6: goto L100;
- case 7: goto L110;
- case 8: goto L120;
- case 9: goto L130;
- case 10: goto L140;
- case 11: goto L150;
- case 12: goto L160;
- case 13: goto L160;
- case 14: goto L160;
- case 15: goto L160;
- case 16: goto L160;
- case 17: goto L160;
- }
-
- /* Invalid value for ISPEC */
-
- ret_val = -1;
- return ret_val;
-
- L10:
-
- /* Convert NAME to upper case if the first character is lower case. */
-
- ret_val = 1;
- s_copy(subnam, name__, (ftnlen)16, name_len);
- ic = *(unsigned char *)subnam;
- iz = 'Z';
- if (iz == 90 || iz == 122) {
-
- /* ASCII character set */
-
- if (ic >= 97 && ic <= 122) {
- *(unsigned char *)subnam = (char) (ic - 32);
- for (i__ = 2; i__ <= 6; ++i__) {
- ic = *(unsigned char *)&subnam[i__ - 1];
- if (ic >= 97 && ic <= 122) {
- *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
- }
- /* L20: */
- }
- }
-
- } else if (iz == 233 || iz == 169) {
-
- /* EBCDIC character set */
-
- if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 &&
- ic <= 169) {
- *(unsigned char *)subnam = (char) (ic + 64);
- for (i__ = 2; i__ <= 6; ++i__) {
- ic = *(unsigned char *)&subnam[i__ - 1];
- if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >=
- 162 && ic <= 169) {
- *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
- }
- /* L30: */
- }
- }
-
- } else if (iz == 218 || iz == 250) {
-
- /* Prime machines: ASCII+128 */
-
- if (ic >= 225 && ic <= 250) {
- *(unsigned char *)subnam = (char) (ic - 32);
- for (i__ = 2; i__ <= 6; ++i__) {
- ic = *(unsigned char *)&subnam[i__ - 1];
- if (ic >= 225 && ic <= 250) {
- *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
- }
- /* L40: */
- }
- }
- }
-
- *(unsigned char *)c1 = *(unsigned char *)subnam;
- sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
- cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
- if (! (cname || sname)) {
- return ret_val;
- }
- s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
- s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
- s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2);
- twostage = i_len(subnam, (ftnlen)16) >= 11 && *(unsigned char *)&subnam[
- 10] == '2';
-
- switch (*ispec) {
- case 1: goto L50;
- case 2: goto L60;
- case 3: goto L70;
- }
-
- L50:
-
- /* ISPEC = 1: block size */
-
- /* In these examples, separate code is provided for setting NB for */
- /* real and complex. We assume that NB will take the same value in */
- /* single or double precision. */
-
- nb = 1;
-
- if (s_cmp(subnam + 1, "LAORH", (ftnlen)5, (ftnlen)5) == 0) {
-
- /* This is for *LAORHR_GETRFNP routine */
-
- if (sname) {
- nb = 32;
- } else {
- nb = 32;
- }
- } else if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 64;
- } else {
- nb = 64;
- }
- } else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3,
- "RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
- 3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3)
- == 0) {
- if (sname) {
- nb = 32;
- } else {
- nb = 32;
- }
- } else if (s_cmp(c3, "QR ", (ftnlen)3, (ftnlen)3) == 0) {
- if (*n3 == 1) {
- if (sname) {
- /* M*N */
- if (*n1 * *n2 <= 131072 || *n1 <= 8192) {
- nb = *n1;
- } else {
- nb = 32768 / *n2;
- }
- } else {
- if (*n1 * *n2 <= 131072 || *n1 <= 8192) {
- nb = *n1;
- } else {
- nb = 32768 / *n2;
- }
- }
- } else {
- if (sname) {
- nb = 1;
- } else {
- nb = 1;
- }
- }
- } else if (s_cmp(c3, "LQ ", (ftnlen)3, (ftnlen)3) == 0) {
- if (*n3 == 2) {
- if (sname) {
- /* M*N */
- if (*n1 * *n2 <= 131072 || *n1 <= 8192) {
- nb = *n1;
- } else {
- nb = 32768 / *n2;
- }
- } else {
- if (*n1 * *n2 <= 131072 || *n1 <= 8192) {
- nb = *n1;
- } else {
- nb = 32768 / *n2;
- }
- }
- } else {
- if (sname) {
- nb = 1;
- } else {
- nb = 1;
- }
- }
- } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 32;
- } else {
- nb = 32;
- }
- } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 32;
- } else {
- nb = 32;
- }
- } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 64;
- } else {
- nb = 64;
- }
- } else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) {
- if (sname) {
- nb = 32;
- } else {
- nb = 32;
- }
- }
- } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 64;
- } else {
- nb = 64;
- }
- }
- } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- if (twostage) {
- nb = 192;
- } else {
- nb = 64;
- }
- } else {
- if (twostage) {
- nb = 192;
- } else {
- nb = 64;
- }
- }
- } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
- nb = 32;
- } else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
- nb = 64;
- }
- } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
- if (twostage) {
- nb = 192;
- } else {
- nb = 64;
- }
- } else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
- nb = 32;
- } else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
- nb = 64;
- }
- } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
- if (*(unsigned char *)c3 == 'G') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nb = 32;
- }
- } else if (*(unsigned char *)c3 == 'M') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nb = 32;
- }
- }
- } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
- if (*(unsigned char *)c3 == 'G') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nb = 32;
- }
- } else if (*(unsigned char *)c3 == 'M') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nb = 32;
- }
- }
- } else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- if (*n4 <= 64) {
- nb = 1;
- } else {
- nb = 32;
- }
- } else {
- if (*n4 <= 64) {
- nb = 1;
- } else {
- nb = 32;
- }
- }
- }
- } else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- if (*n2 <= 64) {
- nb = 1;
- } else {
- nb = 32;
- }
- } else {
- if (*n2 <= 64) {
- nb = 1;
- } else {
- nb = 32;
- }
- }
- }
- } else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 64;
- } else {
- nb = 64;
- }
- } else if (s_cmp(c3, "EVC", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 64;
- } else {
- nb = 64;
- }
- } else if (s_cmp(c3, "SYL", (ftnlen)3, (ftnlen)3) == 0) {
- /* The upper bound is to prevent overly aggressive scaling. */
- if (sname) {
- /* Computing MIN */
- /* Computing MAX */
- i__2 = 48, i__3 = (f2cmin(*n1,*n2) << 4) / 100;
- i__1 = f2cmax(i__2,i__3);
- nb = f2cmin(i__1,240);
- } else {
- /* Computing MIN */
- /* Computing MAX */
- i__2 = 24, i__3 = (f2cmin(*n1,*n2) << 3) / 100;
- i__1 = f2cmax(i__2,i__3);
- nb = f2cmin(i__1,80);
- }
- }
- } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 64;
- } else {
- nb = 64;
- }
- } else if (s_cmp(c3, "TRS", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 32;
- } else {
- nb = 32;
- }
- }
- } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
- nb = 1;
- }
- } else if (s_cmp(c2, "GG", (ftnlen)2, (ftnlen)2) == 0) {
- nb = 32;
- if (s_cmp(c3, "HD3", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nb = 32;
- } else {
- nb = 32;
- }
- }
- }
- ret_val = nb;
- return ret_val;
-
- L60:
-
- /* ISPEC = 2: minimum block size */
-
- nbmin = 2;
- if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
- ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
- ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
- {
- if (sname) {
- nbmin = 2;
- } else {
- nbmin = 2;
- }
- } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nbmin = 2;
- } else {
- nbmin = 2;
- }
- } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nbmin = 2;
- } else {
- nbmin = 2;
- }
- } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nbmin = 2;
- } else {
- nbmin = 2;
- }
- } else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) {
- if (sname) {
- nbmin = 2;
- } else {
- nbmin = 2;
- }
- }
- } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nbmin = 8;
- } else {
- nbmin = 8;
- }
- } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
- nbmin = 2;
- }
- } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
- nbmin = 2;
- }
- } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
- if (*(unsigned char *)c3 == 'G') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nbmin = 2;
- }
- } else if (*(unsigned char *)c3 == 'M') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nbmin = 2;
- }
- }
- } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
- if (*(unsigned char *)c3 == 'G') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nbmin = 2;
- }
- } else if (*(unsigned char *)c3 == 'M') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nbmin = 2;
- }
- }
- } else if (s_cmp(c2, "GG", (ftnlen)2, (ftnlen)2) == 0) {
- nbmin = 2;
- if (s_cmp(c3, "HD3", (ftnlen)3, (ftnlen)3) == 0) {
- nbmin = 2;
- }
- }
- ret_val = nbmin;
- return ret_val;
-
- L70:
-
- /* ISPEC = 3: crossover point */
-
- nx = 0;
- if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
- ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
- ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
- {
- if (sname) {
- nx = 128;
- } else {
- nx = 128;
- }
- } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nx = 128;
- } else {
- nx = 128;
- }
- } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
- if (sname) {
- nx = 128;
- } else {
- nx = 128;
- }
- } else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) {
- if (sname) {
- nx = 128;
- } else {
- nx = 128;
- }
- }
- } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
- if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
- nx = 32;
- }
- } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
- if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
- nx = 32;
- }
- } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
- if (*(unsigned char *)c3 == 'G') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nx = 128;
- }
- }
- } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
- if (*(unsigned char *)c3 == 'G') {
- if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
- (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
- ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
- 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
- c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
- ftnlen)2, (ftnlen)2) == 0) {
- nx = 128;
- }
- }
- } else if (s_cmp(c2, "GG", (ftnlen)2, (ftnlen)2) == 0) {
- nx = 128;
- if (s_cmp(c3, "HD3", (ftnlen)3, (ftnlen)3) == 0) {
- nx = 128;
- }
- }
- ret_val = nx;
- return ret_val;
-
- L80:
-
- /* ISPEC = 4: number of shifts (used by xHSEQR) */
-
- ret_val = 6;
- return ret_val;
-
- L90:
-
- /* ISPEC = 5: minimum column dimension (not used) */
-
- ret_val = 2;
- return ret_val;
-
- L100:
-
- /* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */
-
- ret_val = (integer) ((real) f2cmin(*n1,*n2) * 1.6f);
- return ret_val;
-
- L110:
-
- /* ISPEC = 7: number of processors (not used) */
-
- ret_val = 1;
- return ret_val;
-
- L120:
-
- /* ISPEC = 8: crossover point for multishift (used by xHSEQR) */
-
- ret_val = 50;
- return ret_val;
-
- L130:
-
- /* ISPEC = 9: maximum size of the subproblems at the bottom of the */
- /* computation tree in the divide-and-conquer algorithm */
- /* (used by xGELSD and xGESDD) */
-
- ret_val = 25;
- return ret_val;
-
- L140:
-
- /* ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap */
-
- /* ILAENV = 0 */
- ret_val = 1;
- if (ret_val == 1) {
- ret_val = ieeeck_(&c__1, &c_b179, &c_b180);
- }
- return ret_val;
-
- L150:
-
- /* ISPEC = 11: ieee infinity arithmetic can be trusted not to trap */
-
- /* ILAENV = 0 */
- ret_val = 1;
- if (ret_val == 1) {
- ret_val = ieeeck_(&c__0, &c_b179, &c_b180);
- }
- return ret_val;
-
- L160:
-
- /* 12 <= ISPEC <= 17: xHSEQR or related subroutines. */
-
- ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4)
- ;
- return ret_val;
-
- /* End of ILAENV */
-
- } /* ilaenv_ */
|