/*< subroutine scan1 >*/
/* Subroutine */ int scan1_(void)
{
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
extern /* Subroutine */ int scan2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, char *, ftnlen);
char func___[20];
doublereal a___, b___, c___, m___, w___, y0___, tstop___, dt___;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 5, 0, 0, 0 };
/*< real*8 m_, b_, c_, A_, w_, y0_, tstop_, dt_ >*/
/*< character func_*20 >*/
/*< read(*,*) m_, b_, c_, func_, A_, w_, y0_, tstop_, dt_ >*/
#line 10 "oscillator.f"
s_rsle(&io___1);
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&m___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&b___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&c___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
do_lio(&c__9, &c__1, func___, (ftnlen)20);
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&a___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&w___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&y0___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&tstop___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
do_lio(&c__5, &c__1, (char *)&dt___, (ftnlen)sizeof(doublereal));
#line 10 "oscillator.f"
e_rsle();
/* write(*,*) 'scan1', ' m=', m_, ' b=', b_, ' c=', c_, ' A=', A_, */
/* > ' w=', w_, ' y0=', y0_, ' tstop=', tstop_, ' dt=', dt_, */
/* > ' c-term function:', func_ */
/*< call scan2(m_, b_, c_, A_, w_, y0_, tstop_, dt_, func_) >*/
#line 15 "oscillator.f"
scan2_(&m___, &b___, &c___, &a___, &w___, &y0___, &tstop___, &dt___,
func___, (ftnlen)20);
/*< return >*/
#line 16 "oscillator.f"
return 0;
/*< end >*/
} /* scan1_ */
integer s_rsne(cilist *a)
{
extern int l_eof;
int n;
f__external=1;
l_eof = 0;
if(n = c_le(a))
return n;
if(f__curunit->uwrt && f__nowreading(f__curunit))
err(a->cierr,errno,where0);
l_getc = t_getc;
l_ungetc = un_getc;
f__doend = xrd_SL;
n = x_rsne(a);
nml_read = 0;
if (n)
return n;
return e_rsle();
}
// address: 80486cc
void MAIN__(__size32 param1) {
int local0; // m[esp - 16]
s_wsle();
do_lio();
e_wsle();
s_rsle();
do_lio();
e_rsle();
if (param1 == 2) {
}
if (param1 == 3) {
}
if (param1 == 4) {
}
switch(local0) {
case 0x8048760:
s_wsle();
do_lio();
e_wsle();
break;
case 0x8048793:
s_wsle();
do_lio();
e_wsle();
break;
case 0x80487c3:
s_wsle();
do_lio();
e_wsle();
break;
case 0x80487f3:
s_wsle();
do_lio();
e_wsle();
break;
}
return;
}
int x_rsne(cilist *a)
{
int ch, got1, k, n, nd, quote, readall;
Namelist *nl;
static char where[] = "namelist read";
char buf[64];
hashtab *ht;
Vardesc *v;
dimen *dn, *dn0, *dn1;
ftnlen *dims, *dims1;
ftnlen b, b0, b1, ex, no, nomax, size, span;
ftnint no1, no2, type;
char *vaddr;
long iva, ivae;
dimen dimens[MAXDIM], substr;
if (!Alpha['a'])
nl_init();
f__reading=1;
f__formatted=1;
got1 = 0;
top:
for(;;) switch(GETC(ch)) {
case EOF:
eof:
err(a->ciend,(EOF),where0);
case '&':
case '$':
goto have_amp;
#ifndef No_Namelist_Questions
case '?':
print_ne(a);
continue;
#endif
default:
if (ch <= ' ' && ch >= 0)
continue;
#ifndef No_Namelist_Comments
while(GETC(ch) != '\n')
if (ch == EOF)
goto eof;
#else
errfl(a->cierr, 115, where0);
#endif
}
have_amp:
if (ch = getname(buf,sizeof(buf)))
return ch;
nl = (Namelist *)a->cifmt;
if (strcmp(buf, nl->name))
#ifdef No_Bad_Namelist_Skip
errfl(a->cierr, 118, where0);
#else
{
fprintf(stderr,
"Skipping namelist \"%s\": seeking namelist \"%s\".\n",
buf, nl->name);
fflush(stderr);
for(;;) switch(GETC(ch)) {
case EOF:
err(a->ciend, EOF, where0);
case '/':
case '&':
case '$':
if (f__external)
e_rsle();
else
z_rnew();
goto top;
case '"':
case '\'':
quote = ch;
more_quoted:
while(GETC(ch) != quote)
if (ch == EOF)
err(a->ciend, EOF, where0);
if (GETC(ch) == quote)
goto more_quoted;
Ungetc(ch,f__cf);
default:
continue;
}
}
#endif
ht = mk_hashtab(nl);
if (!ht)
errfl(f__elist->cierr, 113, where0);
for(;;) {
for(;;) switch(GETC(ch)) {
case EOF:
if (got1)
return 0;
err(a->ciend, EOF, where0);
case '/':
case '$':
case '&':
return 0;
default:
if (ch <= ' ' && ch >= 0 || ch == ',')
continue;
Ungetc(ch,f__cf);
if (ch = getname(buf,sizeof(buf)))
return ch;
goto havename;
}
havename:
v = hash(ht,buf);
if (!v)
errfl(a->cierr, 119, where);
while(GETC(ch) <= ' ' && ch >= 0);
vaddr = v->addr;
type = v->type;
if (type < 0) {
size = -type;
type = TYCHAR;
}
else
size = f__typesize[type];
ivae = size;
iva = readall = 0;
if (ch == '(' /*)*/ ) {
dn = dimens;
if (!(dims = v->dims)) {
if (type != TYCHAR)
errfl(a->cierr, 122, where);
if (k = getdimen(&ch, dn, (ftnlen)size,
(ftnlen)size, &b))
errfl(a->cierr, k, where);
if (ch != ')')
errfl(a->cierr, 115, where);
b1 = dn->extent;
if (--b < 0 || b + b1 > size)
return 124;
iva += b;
size = b1;
while(GETC(ch) <= ' ' && ch >= 0);
goto scalar;
}
nd = (int)dims[0];
nomax = span = dims[1];
ivae = iva + size*nomax;
colonseen = 0;
if (k = getdimen(&ch, dn, size, nomax, &b))
errfl(a->cierr, k, where);
no = dn->extent;
b0 = dims[2];
dims1 = dims += 3;
ex = 1;
for(n = 1; n++ < nd; dims++) {
if (ch != ',')
errfl(a->cierr, 115, where);
dn1 = dn + 1;
span /= *dims;
if (k = getdimen(&ch, dn1, dn->delta**dims,
span, &b1))
errfl(a->cierr, k, where);
ex *= *dims;
b += b1*ex;
no *= dn1->extent;
dn = dn1;
}
if (ch != ')')
errfl(a->cierr, 115, where);
readall = 1 - colonseen;
b -= b0;
if (b < 0 || b >= nomax)
errfl(a->cierr, 125, where);
iva += size * b;
dims = dims1;
while(GETC(ch) <= ' ' && ch >= 0);
no1 = 1;
dn0 = dimens;
if (type == TYCHAR && ch == '(' /*)*/) {
if (k = getdimen(&ch, &substr, size, size, &b))
errfl(a->cierr, k, where);
if (ch != ')')
errfl(a->cierr, 115, where);
b1 = substr.extent;
if (--b < 0 || b + b1 > size)
return 124;
iva += b;
b0 = size;
size = b1;
while(GETC(ch) <= ' ' && ch >= 0);
if (b1 < b0)
goto delta_adj;
}
if (readall)
goto delta_adj;
for(; dn0 < dn; dn0++) {
if (dn0->extent != *dims++ || dn0->stride != 1)
break;
no1 *= dn0->extent;
}
if (dn0 == dimens && dimens[0].stride == 1) {
no1 = dimens[0].extent;
dn0++;
}
delta_adj:
ex = 0;
for(dn1 = dn0; dn1 <= dn; dn1++)
ex += (dn1->extent-1)
* (dn1->delta *= dn1->stride);
for(dn1 = dn; dn1 > dn0; dn1--) {
ex -= (dn1->extent - 1) * dn1->delta;
dn1->delta -= ex;
}
}
else if (dims = v->dims) {
no = no1 = dims[1];
ivae = iva + no*size;
}
else
scalar:
no = no1 = 1;
if (ch != '=')
errfl(a->cierr, 115, where);
got1 = nml_read = 1;
f__lcount = 0;
readloop:
for(;;) {
if (iva >= ivae || iva < 0) {
f__lquit = 1;
goto mustend;
}
else if (iva + no1*size > ivae)
no1 = (ivae - iva)/size;
f__lquit = 0;
if (k = l_read(&no1, vaddr + iva, size, type))
return k;
if (f__lquit == 1)
return 0;
if (readall) {
iva += dn0->delta;
if (f__lcount > 0) {
no2 = (ivae - iva)/size;
if (no2 > f__lcount)
no2 = f__lcount;
if (k = l_read(&no2, vaddr + iva,
size, type))
return k;
iva += no2 * dn0->delta;
}
}
mustend:
GETC(ch);
if (readall)
if (iva >= ivae)
readall = 0;
else for(;;) {
switch(ch) {
case ' ':
case '\t':
case '\n':
GETC(ch);
continue;
}
break;
}
if (ch == '/' || ch == '$' || ch == '&') {
f__lquit = 1;
return 0;
}
else if (f__lquit) {
while(ch <= ' ' && ch >= 0)
GETC(ch);
Ungetc(ch,f__cf);
if (!Alpha[ch & 0xff] && ch >= 0)
errfl(a->cierr, 125, where);
break;
}
Ungetc(ch,f__cf);
if (readall && !Alpha[ch & 0xff])
goto readloop;
if ((no -= no1) <= 0)
break;
for(dn1 = dn0; dn1 <= dn; dn1++) {
if (++dn1->curval < dn1->extent) {
iva += dn1->delta;
goto readloop;
}
dn1->curval = 0;
}
break;
}
}
}
/* Subroutine */ int zchkbk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9994[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer info, lmax[2];
static doublereal rmax, vmax;
static doublecomplex e[400] /* was [20][20] */;
static integer i__, j, n;
static doublereal scale[20], x;
static integer ninfo;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublecomplex *, integer *,
integer *);
static doublereal safmin;
static integer ihi;
static doublecomplex ein[400] /* was [20][20] */;
static integer ilo;
static doublereal eps;
static integer knt;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
#define e_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define ein_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define ein_ref(a_1,a_2) ein[ein_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZCHKBK tests ZGEBAK, a routine for backward transformation of
the computed right or left eigenvectors if the orginal matrix
was preprocessed by balance subroutine ZGEBAL.
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
====================================================================== */
lmax[0] = 0;
lmax[1] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("E");
safmin = dlamch_("S");
L10:
io___7.ciunit = *nin;
s_rsle(&io___7);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L60;
}
io___11.ciunit = *nin;
s_rsle(&io___11);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nin;
s_rsle(&io___14);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&e_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ein_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L30: */
}
++knt;
zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = e_subscr(i__, j);
i__4 = ein_subscr(i__, j);
z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
)) / eps;
i__3 = e_subscr(i__, j);
if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e_ref(i__, j))
, abs(d__2)) > safmin) {
i__4 = e_subscr(i__, j);
x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e_ref(
i__, j)), abs(d__4));
}
vmax = max(vmax,x);
/* L40: */
}
/* L50: */
}
if (vmax > rmax) {
lmax[1] = knt;
rmax = vmax;
}
goto L10;
L60:
io___22.ciunit = *nout;
s_wsfe(&io___22);
e_wsfe();
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBK */
} /* zchkbk_ */
/* Subroutine */ int ddrvsx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
integer *nounit, doublereal *a, integer *lda, doublereal *h__,
doublereal *ht, doublereal *wr, doublereal *wi, doublereal *wrt,
doublereal *wit, doublereal *wrtmp, doublereal *witmp, doublereal *vs,
integer *ldvs, doublereal *vs1, doublereal *result, doublereal *work,
integer *lwork, integer *iwork, logical *bwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9991[] = "(\002 DDRVSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
"Expert \002,\002Driver\002,/\002 Matrix types (see DDRVSX for de"
"tails):\002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
"\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
" otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
"p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
" (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
" T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
"e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
"e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
"rt)\002,\002, 1/ulp otherwise\002)";
static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
"/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
"( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
"lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
"T same no matter what else computed (sort),\002,\002 1/ulp othe"
"rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
"ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
"succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
"tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
" 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
"therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
"RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
"RCONDV),\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static doublereal cond;
static integer jcol;
static char path[3];
static integer nmax;
static doublereal unfl, ovfl;
static integer i__, j, n;
static logical badnn;
static integer nfail;
extern /* Subroutine */ int dget24_(logical *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, logical *, integer *);
static integer imode, iinfo;
static doublereal conds, anorm;
static integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
static doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
static doublereal rcdein;
static char adumma[1*1];
extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, char *, char *, doublereal *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *);
static integer idumma[1], ioldsd[4];
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlatmr_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, char *, char *, doublereal *, integer *, doublereal
*, doublereal *, integer *, doublereal *, char *, integer *,
integer *, integer *, doublereal *, doublereal *, char *,
doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublereal *, integer
*, doublereal *, integer *);
static doublereal rcdvin;
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*);
static integer ntestf;
static doublereal ulpinv;
static integer nnwork;
static doublereal rtulpi;
static integer mtypes, ntestt, iwk;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___48 = { 0, 0, 1, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
expert driver DGEESX.
DDRVSX uses both test matrices generated randomly depending on
data supplied in the calling sequence, as well as on data
read from an input file and including precomputed condition
numbers to which it compares the ones it computes.
When DDRVSX is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, one matrix will be generated and used
to test the nonsymmetric eigenroutines. For each matrix, 15
tests will be performed:
(1) 0 if T is in Schur form, 1/ulp otherwise
(no sorting of eigenvalues)
(2) | A - VS T VS' | / ( n |A| ulp )
Here VS is the matrix of Schur eigenvectors, and T is in Schur
form (no sorting of eigenvalues).
(3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
(4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
1/ulp otherwise
(no sorting of eigenvalues)
(5) 0 if T(with VS) = T(without VS),
1/ulp otherwise
(no sorting of eigenvalues)
(6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
1/ulp otherwise
(no sorting of eigenvalues)
(7) 0 if T is in Schur form, 1/ulp otherwise
(with sorting of eigenvalues)
(8) | A - VS T VS' | / ( n |A| ulp )
Here VS is the matrix of Schur eigenvectors, and T is in Schur
form (with sorting of eigenvalues).
(9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
(10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
1/ulp otherwise
If workspace sufficient, also compare WR, WI with and
without reciprocal condition numbers
(with sorting of eigenvalues)
(11) 0 if T(with VS) = T(without VS),
1/ulp otherwise
If workspace sufficient, also compare T with and without
reciprocal condition numbers
(with sorting of eigenvalues)
(12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
1/ulp otherwise
If workspace sufficient, also compare VS with and without
reciprocal condition numbers
(with sorting of eigenvalues)
(13) if sorting worked and SDIM is the number of
eigenvalues which were SELECTed
If workspace sufficient, also compare SDIM with and
without reciprocal condition numbers
(14) if RCONDE the same no matter if VS and/or RCONDV computed
(15) if RCONDV the same no matter if VS and/or RCONDE computed
The "sizes" are specified by an array NN(1:NSIZES); the value of
each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES );
if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) The zero matrix.
(2) The identity matrix.
(3) A (transposed) Jordan block, with 1's on the diagonal.
(4) A diagonal matrix with evenly spaced entries
1, ..., ULP and random signs.
(ULP = (first number larger than 1) - 1 )
(5) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(7) Same as (4), but multiplied by a constant near
the overflow threshold
(8) Same as (4), but multiplied by a constant near
the underflow threshold
(9) A matrix of the form U' T U, where U is orthogonal and
T has evenly spaced entries 1, ..., ULP with random signs
on the diagonal and random O(1) entries in the upper
triangle.
(10) A matrix of the form U' T U, where U is orthogonal and
T has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(11) A matrix of the form U' T U, where U is orthogonal and
T has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(12) A matrix of the form U' T U, where U is orthogonal and
T has real or complex conjugate paired eigenvalues randomly
chosen from ( ULP, 1 ) and random O(1) entries in the upper
triangle.
(13) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(14) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has geometrically spaced entries
1, ..., ULP with random signs on the diagonal and random
O(1) entries in the upper triangle.
(15) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(16) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has real or complex conjugate paired
eigenvalues randomly chosen from ( ULP, 1 ) and random
O(1) entries in the upper triangle.
(17) Same as (16), but multiplied by a constant
near the overflow threshold
(18) Same as (16), but multiplied by a constant
near the underflow threshold
(19) Nonsymmetric matrix with random entries chosen from (-1,1).
If N is at least 4, all entries in first two rows and last
row, and first column and last two columns are zero.
(20) Same as (19), but multiplied by a constant
near the overflow threshold
(21) Same as (19), but multiplied by a constant
near the underflow threshold
In addition, an input file will be read from logical unit number
NIUNIT. The file contains matrices along with precomputed
eigenvalues and reciprocal condition numbers for the eigenvalue
average and right invariant subspace. For these matrices, in
addition to tests (1) to (15) we will compute the following two
tests:
(16) |RCONDE - RCDEIN| / cond(RCONDE)
RCONDE is the reciprocal average eigenvalue condition number
computed by DGEESX and RCDEIN (the precomputed true value)
is supplied as input. cond(RCONDE) is the condition number
of RCONDE, and takes errors in computing RCONDE into account,
so that the resulting quantity should be O(ULP). cond(RCONDE)
is essentially given by norm(A)/RCONDV.
(17) |RCONDV - RCDVIN| / cond(RCONDV)
RCONDV is the reciprocal right invariant subspace condition
number computed by DGEESX and RCDVIN (the precomputed true
value) is supplied as input. cond(RCONDV) is the condition
number of RCONDV, and takes errors in computing RCONDV into
account, so that the resulting quantity should be O(ULP).
cond(RCONDV) is essentially given by norm(A)/RCONDE.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. NSIZES must be at
least zero. If it is zero, no randomly generated matrices
are tested, but any test matrices read from NIUNIT will be
tested.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. The values must be at least
zero.
NTYPES (input) INTEGER
The number of elements in DOTYPE. NTYPES must be at least
zero. If it is zero, no randomly generated test matrices
are tested, but and test matrices read from NIUNIT will be
tested. If it is MAXTYP+1 and NSIZES is 1, then an
additional type, MAXTYP+1 is defined, which is to use
whatever matrix is in A. This is only useful if
DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DDRVSX to continue the same random number
sequence.
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. It must be at least zero.
NIUNIT (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns INFO not equal to 0.)
A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
Used to hold the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of A, and H. LDA must be at
least 1 and at least max( NN ).
H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
Another copy of the test matrix A, modified by DGEESX.
HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
Yet another copy of the test matrix A, modified by DGEESX.
WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
The real and imaginary parts of the eigenvalues of A.
On exit, WR + WI*i are the eigenvalues of the matrix in A.
WRT (workspace) DOUBLE PRECISION array, dimension (max(NN))
WIT (workspace) DOUBLE PRECISION array, dimension (max(NN))
Like WR, WI, these arrays contain the eigenvalues of A,
but those computed when DGEESX only computes a partial
eigendecomposition, i.e. not Schur vectors
WRTMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
WITMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
More temporary storage for eigenvalues.
VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
VS holds the computed Schur vectors.
LDVS (input) INTEGER
Leading dimension of VS. Must be at least max(1,max(NN)).
VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
VS1 holds another copy of the computed Schur vectors.
RESULT (output) DOUBLE PRECISION array, dimension (17)
The values computed by the 17 tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
max(3*NN(j),2*NN(j)**2) for all j.
IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN))
INFO (output) INTEGER
If 0, successful exit.
<0, input parameter -INFO is incorrect
>0, DLATMR, SLATMS, SLATME or DGET24 returned an error
code and INFO is its absolute value
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
NMAX Largest value in NN.
NERRS The number of tests which have exceeded THRESH
COND, CONDS,
IMODE Values to be passed to the matrix generators.
ANORM Norm of A; passed to matrix generators.
OVFL, UNFL Overflow and underflow thresholds.
ULP, ULPINV Finest relative precision and its inverse.
RTULP, RTULPI Square roots of the previous 4 values.
The following four arrays decode JTYPE:
KTYPE(j) The general type (1-10) for type "j".
KMODE(j) The MODE value to be passed to the matrix
generator for type "j".
KMAGN(j) The order of magnitude ( O(1),
O(overflow^(1/2) ), O(underflow^(1/2) )
KCONDS(j) Selectw whether CONDS is to be 1 or
1/sqrt(ulp). (0 means irrelevant.)
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
ht_dim1 = *lda;
ht_offset = 1 + ht_dim1 * 1;
ht -= ht_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--wr;
--wi;
--wrt;
--wit;
--wrtmp;
--witmp;
vs1_dim1 = *ldvs;
vs1_offset = 1 + vs1_dim1 * 1;
vs1 -= vs1_offset;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1 * 1;
vs -= vs_offset;
--result;
--work;
--iwork;
--bwork;
/* Function Body */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed
problems */
nmax = 12;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*niunit <= 0) {
*info = -7;
} else if (*nounit <= 0) {
*info = -8;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvs < 1 || *ldvs < nmax) {
*info = -20;
} else /* if(complicated condition) */ {
/* Computing MAX
Computing 2nd power */
i__3 = nmax;
i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
if (max(i__1,i__2) > *lwork) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRVSX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L150;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L130;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A"
Control parameters:
KMAGN KCONDS KMODE KTYPE
=1 O(1) 1 clustered 1 zero
=2 large large clustered 2 identity
=3 small exponential Jordan
=4 arithmetic diagonal, (w/ eigenvalues)
=5 random log symmetric, w/ eigenvalues
=6 random general, w/ eigenvalues
=7 random diagonal
=8 random symmetric
=9 random general
=10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block
Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
if (jcol > 1) {
a_ref(jcol, jcol - 1) = 1.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
*(unsigned char *)&adumma[0] = ' ';
dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
dlaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
dlaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a_ref(3, 1)
, lda);
i__3 = n - 3;
dlaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a_ref(3, n
- 1), lda);
dlaset_("Full", &c__1, &n, &c_b18, &c_b18, &a_ref(n, 1),
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n * 3;
} else {
/* Computing MAX */
i__3 = n * 3, i__4 = (n << 1) * n;
nnwork = max(i__3,i__4);
}
nnwork = max(nnwork,1);
dget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
&nslct, islct, &result[1], &work[1], &nnwork, &iwork[
1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 15; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
io___46.ciunit = *nounit;
s_wsfe(&io___46);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 15; ++j) {
if (result[j] >= *thresh) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
L130:
;
}
/* L140: */
}
L150:
/* Read in data from file to check accuracy of condition estimation
Read input data until N=0 */
jtype = 0;
L160:
io___48.ciunit = *niunit;
i__1 = s_rsle(&io___48);
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L200;
}
if (n == 0) {
goto L200;
}
++jtype;
iseed[1] = jtype;
if (nslct > 0) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
i__1 = nslct;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___51.ciunit = *niunit;
s_rsle(&io___51);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L170: */
}
io___52.ciunit = *niunit;
s_rsle(&io___52);
do_lio(&c__5, &c__1, (char *)&rcdein, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&rcdvin, (ftnlen)sizeof(doublereal));
e_rsle();
dget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
&h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
&wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
iwork[1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 17; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L180: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 17; ++j) {
if (result[j] >= *thresh) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* L190: */
}
nerrs += nfail;
ntestt += ntest;
goto L160;
L200:
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of DDRVSX */
} /* ddrvsx_ */
/* Subroutine */ int cdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, complex *a, integer *lda, complex *h__, complex *w,
complex *w1, complex *vl, integer *ldvl, complex *vr, integer *ldvr,
complex *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
scale1, real *result, complex *work, integer *nwork, real *rwork,
integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
static char bal[1*4] = "N" "P" "S" "B";
/* Format strings */
static char fmt_9992[] = "(\002 CDRVVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Expert Driver\002,/\002 Matrix types ("
"see CDRVVX for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
"22=Matrix read from input file\002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
"|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
"/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
"/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
"mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
"matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
" = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
"p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
"tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
"= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
"= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
"WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
"\002, test(\002,i2,\002)=\002,g10.3)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
integer i__, j, n;
real wi, wr;
integer iwk;
real ulp;
integer ibal;
real cond;
integer jcol;
char path[3];
integer nmax;
real unfl, ovfl;
integer isrt;
logical badnn;
extern /* Subroutine */ int cget23_(logical *, integer *, char *, integer
*, real *, integer *, integer *, integer *, complex *, integer *,
complex *, complex *, complex *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, complex *, integer *,
real *, integer *);
integer nfail, imode, iinfo;
real conds, anorm;
integer jsize, nerrs, itype, jtype, ntest;
real rtulp;
char balanc[1];
extern /* Subroutine */ int slabad_(real *, real *), clatme_(integer *,
char *, integer *, complex *, integer *, real *, complex *, char *
, char *, char *, char *, real *, integer *, real *, integer *,
integer *, real *, complex *, integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
integer idumma[1];
integer ioldsd[4];
extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
*, char *, complex *, integer *, real *, complex *, char *, char *
, complex *, integer *, real *, complex *, integer *, real *,
char *, integer *, integer *, integer *, real *, real *, char *,
complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, complex *, integer *, complex *,
integer *);
integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*);
integer nnwork;
real rtulpi;
integer mtypes, ntestt;
real ulpinv;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___45 = { 0, 0, 1, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVVX checks the nonsymmetric eigenvalue problem expert driver */
/* CGEEVX. */
/* CDRVVX uses both test matrices generated randomly depending on */
/* data supplied in the calling sequence, as well as on data */
/* read from an input file and including precomputed condition */
/* numbers to which it compares the ones it computes. */
/* When CDRVVX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified in the calling sequence. */
/* For each size ("n") and each type of matrix, one matrix will be */
/* generated and used to test the nonsymmetric eigenroutines. For */
/* each matrix, 9 tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a diagonal matrix with diagonal entries W(j). */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
/* and RCONDE are also computed, and W(partial) denotes the */
/* eigenvalues computed when only some of VR, VL, RCONDV, and */
/* RCONDE are computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
/* and RCONDE are computed, and VR(partial) denotes the result */
/* when only some of VL and RCONDV are computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
/* and RCONDE are computed, and VL(partial) denotes the result */
/* when only some of VR and RCONDV are computed. */
/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
/* SCALE, ILO, IHI, ABNRM (partial) */
/* 1/ulp otherwise */
/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
/* (partial) is when some are not computed. */
/* (9) RCONDV(full) = RCONDV(partial) */
/* RCONDV(full) denotes the reciprocal condition numbers of the */
/* right eigenvectors computed when VR, VL and RCONDE are also */
/* computed. RCONDV(partial) denotes the reciprocal condition */
/* numbers when only some of VR, VL and RCONDE are computed. */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalues */
/* and right eigenvectors. For these matrices, in addition to tests */
/* (1) to (9) we will compute the following two tests: */
/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right eigenvector condition number */
/* computed by CGEEVX and RCDVIN (the precomputed true value) */
/* is supplied as input. cond(RCONDV) is the condition number of */
/* RCONDV, and takes errors in computing RCONDV into account, so */
/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
/* essentially given by norm(A)/RCONDE. */
/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal eigenvalue condition number */
/* computed by CGEEVX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
/* additional type, MAXTYP+1 is defined, which is to use */
/* whatever matrix is in A. This is only useful if */
/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to CDRVVX to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIUNIT (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) COMPLEX array, dimension (LDA, max(NN,12)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max( NN, 12 ). (12 is the */
/* dimension of the largest matrix on the precomputed */
/* input file.) */
/* H (workspace) COMPLEX array, dimension (LDA, max(NN,12)) */
/* Another copy of the test matrix A, modified by CGEEVX. */
/* W (workspace) COMPLEX array, dimension (max(NN,12)) */
/* Contains the eigenvalues of A. */
/* W1 (workspace) COMPLEX array, dimension (max(NN,12)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when CGEEVX only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) COMPLEX array, dimension (LDVL, max(NN,12)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
/* VR (workspace) COMPLEX array, dimension (LDVR, max(NN,12)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
/* LRE (workspace) COMPLEX array, dimension (LDLRE, max(NN,12)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
/* RESULT (output) REAL array, dimension (11) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) COMPLEX array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
/* RWORK (workspace) REAL array, dimension (2*max(NN,12)) */
/* INFO (output) INTEGER */
/* If 0, then successful exit. */
/* If <0, then input paramter -INFO is incorrect. */
/* If >0, CLATMR, CLATMS, CLATME or CGET23 returned an error */
/* code, and INFO is its absolute value. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN or 12. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--rwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 7 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 7;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -15;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -17;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -19;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
*info = -30;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVVX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L160;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L140;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1.f, a[i__4].i = 0.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "S", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
&iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
if (n >= 4) {
claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 3; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else if (iwk == 2) {
/* Computing 2nd power */
i__3 = n;
nnwork = (n << 1) + i__3 * i__3;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Test for all balancing options */
for (ibal = 1; ibal <= 4; ++ibal) {
*(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
1];
/* Perform tests */
cget23_(&c_false, &c__0, balanc, &jtype, thresh, ioldsd,
nounit, &n, &a[a_offset], lda, &h__[h_offset], &w[
1], &w1[1], &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
rcdein[1], &scale[1], &scale1[1], &result[1], &
work[1], &nnwork, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 9; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___40.ciunit = *nounit;
s_wsfe(&io___40);
e_wsfe();
io___41.ciunit = *nounit;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real)
);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 9; ++j) {
if (result[j] >= *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, balanc, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
/* L130: */
}
L140:
;
}
/* L150: */
}
L160:
/* Read in data from file to check accuracy of condition estimation. */
/* Assume input eigenvalues are sorted lexicographically (increasing */
/* by real part, then decreasing by imaginary part) */
jtype = 0;
L170:
io___45.ciunit = *niunit;
i__1 = s_rsle(&io___45);
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L220;
}
/* Read input data until N=0 */
if (n == 0) {
goto L220;
}
++jtype;
iseed[1] = jtype;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___48.ciunit = *niunit;
s_rsle(&io___48);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
complex));
}
e_rsle();
/* L180: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
do_lio(&c__4, &c__1, (char *)&wr, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wi, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(real));
e_rsle();
i__2 = i__;
q__1.r = wr, q__1.i = wi;
w1[i__2].r = q__1.r, w1[i__2].i = q__1.i;
/* L190: */
}
/* Computing 2nd power */
i__2 = n;
i__1 = n * 6 + (i__2 * i__2 << 1);
cget23_(&c_true, &isrt, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[
a_offset], lda, &h__[h_offset], &w[1], &w1[1], &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &rcdein[1], &scale[
1], &scale1[1], &result[1], &work[1], &i__1, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 11; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L200: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 11; ++j) {
if (result[j] >= *thresh) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
/* L210: */
}
nerrs += nfail;
ntestt += ntest;
goto L170;
L220:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of CDRVVX */
} /* cdrvvx_ */
/* Subroutine */ int deriv_(doublereal *geo, doublereal *grad)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
char ch__1[80];
olist o__1;
alist al__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), f_open(olist *), f_rew(
alist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void), s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double pow_di(doublereal *, integer *), sqrt(doublereal);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j;
static logical ci;
static integer ii, ij, il, jl, kl, ll, kk;
static logical aic;
extern doublereal dot_(doublereal *, doublereal *, integer *);
static logical int__;
extern /* Subroutine */ int mxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static doublereal sum;
static logical scf1;
static char line[80];
static integer ncol;
static doublereal xjuc[3], step;
static logical slow;
static integer icapa;
static logical halfe, debug;
extern /* Subroutine */ int dcart_(doublereal *, doublereal *);
static integer iline;
static logical geook;
static doublereal grlim;
static integer ilowa;
static doublereal gnorm;
extern /* Subroutine */ int geout_(integer *);
static integer ilowz;
static doublereal change[3], aidref[360];
static integer idelta;
extern /* Character */ VOID getnam_(char *, ftnlen, char *, ftnlen);
static logical precis, noanci, aifrst;
extern /* Subroutine */ int dernvo_(doublereal *, doublereal *), jcarin_(
doublereal *, doublereal *, doublereal *, logical *, doublereal *,
integer *), gmetry_(doublereal *, doublereal *), deritr_(
doublereal *, doublereal *), symtry_(void);
/* Fortran I/O blocks */
static cilist io___14 = { 0, 5, 0, "(A)", 0 };
static cilist io___17 = { 1, 5, 1, "(A)", 0 };
static cilist io___19 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___20 = { 0, 6, 0, "(A)", 0 };
static cilist io___21 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___22 = { 0, 6, 0, "(A)", 0 };
static cilist io___23 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___25 = { 1, 5, 1, 0, 0 };
static cilist io___26 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___27 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___28 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___29 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___31 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___32 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___37 = { 0, 6, 0, "(' GEO AT START OF DERIV')", 0 };
static cilist io___38 = { 0, 6, 0, "(F19.5,2F12.5)", 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, "(//,3(A,/),I3,A)", 0 };
static cilist io___55 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, "(' GRADIENTS')", 0 };
static cilist io___58 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___59 = { 0, 6, 0, "(' ERROR FUNCTION')", 0 };
static cilist io___60 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___61 = { 0, 6, 0, "(' COSINE OF SEARCH DIRECTION =',F30"
".6)", 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* *********************************************************************** */
/* DERIV CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE */
/* INTERNAL COORDINATES. THIS IS DONE BY FINITE DIFFERENCES. */
/* THE MAIN ARRAYS IN DERIV ARE: */
/* LOC INTEGER ARRAY, LOC(1,I) CONTAINS THE ADDRESS OF THE ATOM */
/* INTERNAL COORDINATE LOC(2,I) IS TO BE USED IN THE */
/* DERIVATIVE CALCULATION. */
/* GEO ARRAY \GEO\ HOLDS THE INTERNAL COORDINATES. */
/* GRAD ON EXIT, CONTAINS THE DERIVATIVES */
/* *********************************************************************** */
/* Parameter adjustments */
--grad;
geo -= 4;
/* Function Body */
if (icalcn != numcal_1.numcal) {
aifrst = i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) ==
0;
debug = i_indx(keywrd_1.keywrd, "DERIV", (ftnlen)241, (ftnlen)5) != 0;
precis = i_indx(keywrd_1.keywrd, "PREC", (ftnlen)241, (ftnlen)4) != 0;
int__ = i_indx(keywrd_1.keywrd, " XYZ", (ftnlen)241, (ftnlen)4) == 0;
geook = i_indx(keywrd_1.keywrd, "GEO-OK", (ftnlen)241, (ftnlen)6) !=
0;
ci = i_indx(keywrd_1.keywrd, "C.I.", (ftnlen)241, (ftnlen)4) != 0;
scf1 = i_indx(keywrd_1.keywrd, "1SCF", (ftnlen)241, (ftnlen)4) != 0;
aic = i_indx(keywrd_1.keywrd, "AIDER", (ftnlen)241, (ftnlen)5) != 0;
icapa = 'A';
ilowa = 'a';
ilowz = 'z';
if (aic && aifrst) {
o__1.oerr = 0;
o__1.ounit = 5;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR005", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = "ZERO";
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 5;
f_rew(&al__1);
/* ISOK IS SET FALSE: ONLY ONE SYSTEM ALLOWED */
okmany_1.isok = FALSE_;
for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
s_rsfe(&io___14);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
}
for (j = 1; j <= 1000; ++j) {
i__1 = s_rsfe(&io___17);
if (i__1 != 0) {
goto L40;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L40;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L40;
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= ilowa && iline <= ilowz) {
*(unsigned char *)&line[i__ - 1] = (char) (iline +
icapa - ilowa);
}
/* L20: */
}
/* *********************************************************************** */
/* L30: */
if (i_indx(line, "AIDER", (ftnlen)80, (ftnlen)5) != 0) {
goto L60;
}
}
L40:
s_wsfe(&io___19);
do_fio(&c__1, " KEYWORD \"AIDER\" SPECIFIED, BUT NOT", (ftnlen)35)
;
e_wsfe();
s_wsfe(&io___20);
do_fio(&c__1, " PRESENT AFTER Z-MATRIX. JOB STOPPED", (ftnlen)37)
;
e_wsfe();
s_stop("", (ftnlen)0);
L50:
s_wsfe(&io___21);
do_fio(&c__1, " FAULT IN READ OF AB INITIO DERIVATIVES", (ftnlen)
40);
e_wsfe();
s_wsfe(&io___22);
do_fio(&c__1, " DERIVATIVES READ IN ARE AS FOLLOWS", (ftnlen)36);
e_wsfe();
s_wsfe(&io___23);
i__1 = i__;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_stop("", (ftnlen)0);
L60:
if (geokst_1.natoms > 2) {
j = geokst_1.natoms * 3 - 6;
} else {
j = 1;
}
i__1 = s_rsle(&io___25);
if (i__1 != 0) {
goto L50;
}
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_lio(&c__5, &c__1, (char *)&aidref[i__ - 1], (ftnlen)
sizeof(doublereal));
if (i__1 != 0) {
goto L50;
}
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L50;
}
s_wsfe(&io___26);
do_fio(&c__1, " AB-INITIO DERIVATIVES IN KCAL/MOL/(ANGSTROM OR R"
"ADIAN)", (ftnlen)55);
e_wsfe();
s_wsfe(&io___27);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geovar_1.loc[(i__ << 1) - 2] > 3) {
j = geovar_1.loc[(i__ << 1) - 2] * 3 + geovar_1.loc[(i__
<< 1) - 1] - 9;
} else if (geovar_1.loc[(i__ << 1) - 2] == 3) {
j = geovar_1.loc[(i__ << 1) - 1] + 1;
} else {
j = 1;
}
/* L70: */
aidref[i__ - 1] = aidref[j - 1];
}
s_wsfe(&io___28);
do_fio(&c__1, " AB-INITIO DERIVATIVES FOR VARIABLES", (ftnlen)36);
e_wsfe();
s_wsfe(&io___29);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
if (geosym_1.ndep != 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
sum = aidref[i__ - 1];
i__2 = geosym_1.ndep;
for (j = 1; j <= i__2; ++j) {
if (geovar_1.loc[(i__ << 1) - 2] == geosym_1.locpar[j
- 1] && (geovar_1.loc[(i__ << 1) - 1] ==
geosym_1.idepfn[j - 1] || geovar_1.loc[(i__ <<
1) - 1] == 3 && geosym_1.idepfn[j - 1] == 14)
) {
aidref[i__ - 1] += sum;
}
/* L80: */
}
/* L90: */
}
s_wsfe(&io___31);
do_fio(&c__1, " AB-INITIO DERIVATIVES AFTER SYMMETRY WEIGHTI"
"NG", (ftnlen)47);
e_wsfe();
s_wsfe(&io___32);
i__1 = geovar_1.nvar;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
icalcn = numcal_1.numcal;
if (i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) == 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
errfn_1.errfn[i__ - 1] = 0.;
}
}
grlim = .01;
if (precis) {
grlim = 1e-4;
}
halfe = molkst_1.nopen > molkst_1.nclose && molkst_1.fract != 2. &&
molkst_1.fract != 0. || ci;
idelta = -7;
/* IDELTA IS A MACHINE-PRECISION DEPENDANT INTEGER */
change[0] = pow_di(&c_b70, &idelta);
change[1] = pow_di(&c_b70, &idelta);
change[2] = pow_di(&c_b70, &idelta);
/* CHANGE(I) IS THE STEP SIZE USED IN CALCULATING THE DERIVATIVES. */
/* FOR "CARTESIAN" DERIVATIVES, CALCULATED USING DCART,AN */
/* INFINITESIMAL STEP, HERE 0.000001, IS ACCEPTABLE. IN THE */
/* HALF-ELECTRON METHOD A QUITE LARGE STEP IS NEEDED AS FULL SCF */
/* CALCULATIONS ARE NEEDED, AND THE DIFFERENCE BETWEEN THE TOTAL */
/* ENERGIES IS USED. THE STEP CANNOT BE VERY LARGE, AS THE SECOND */
/* DERIVITIVE IN FLEPO IS CALCULATED FROM THE DIFFERENCES OF TWO */
/* FIRST DERIVATIVES. CHANGE(1) IS FOR CHANGE IN BOND LENGTH, */
/* (2) FOR ANGLE, AND (3) FOR DIHEDRAL. */
}
if (geovar_1.nvar == 0) {
return 0;
}
if (debug) {
s_wsfe(&io___37);
e_wsfe();
s_wsfe(&io___38);
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
do_fio(&c__1, (char *)&geo[j + i__ * 3], (ftnlen)sizeof(
doublereal));
}
}
e_wsfe();
}
gnorm = 0.;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
genral_1.gold[i__ - 1] = grad[i__];
genral_1.xparam[i__ - 1] = geo[geovar_1.loc[(i__ << 1) - 1] +
geovar_1.loc[(i__ << 1) - 2] * 3];
/* L110: */
/* Computing 2nd power */
d__1 = grad[i__];
gnorm += d__1 * d__1;
}
gnorm = sqrt(gnorm);
slow = FALSE_;
noanci = FALSE_;
if (halfe) {
noanci = i_indx(keywrd_1.keywrd, "NOANCI", (ftnlen)241, (ftnlen)6) !=
0 || molkst_1.nopen == molkst_1.norbs;
slow = noanci && (gnorm < grlim || scf1);
}
if (geosym_1.ndep != 0) {
symtry_();
}
gmetry_(&geo[4], genral_1.coord);
/* COORD NOW HOLDS THE CARTESIAN COORDINATES */
if (halfe && ! noanci) {
if (debug) {
s_wsle(&io___42);
do_lio(&c__9, &c__1, "DOING ANALYTICAL C.I. DERIVATIVES", (ftnlen)
33);
e_wsle();
}
dernvo_(genral_1.coord, xyzgra_1.dxyz);
} else {
if (debug) {
s_wsle(&io___43);
do_lio(&c__9, &c__1, "DOING VARIATIONALLY OPIMIZED DERIVATIVES", (
ftnlen)40);
e_wsle();
}
dcart_(genral_1.coord, xyzgra_1.dxyz);
}
ij = 0;
i__1 = molkst_1.numat;
for (ii = 1; ii <= i__1; ++ii) {
i__2 = ucell_1.l1u;
for (il = ucell_1.l1l; il <= i__2; ++il) {
i__3 = ucell_1.l2u;
for (jl = ucell_1.l2l; jl <= i__3; ++jl) {
i__4 = ucell_1.l3u;
for (kl = ucell_1.l3l; kl <= i__4; ++kl) {
/* $DOIT ASIS */
for (ll = 1; ll <= 3; ++ll) {
/* L120: */
xjuc[ll - 1] = genral_1.coord[ll + ii * 3 - 4] +
euler_1.tvec[ll - 1] * il + euler_1.tvec[ll +
2] * jl + euler_1.tvec[ll + 5] * kl;
}
++ij;
/* $DOIT ASIS */
for (kk = 1; kk <= 3; ++kk) {
genral_1.cold[kk + ij * 3 - 4] = xjuc[kk - 1];
/* L130: */
}
/* L140: */
}
}
}
/* L150: */
}
step = change[0];
jcarin_(genral_1.coord, genral_1.xparam, &step, &precis, work3_1.work2, &
ncol);
mxm_(work3_1.work2, &geovar_1.nvar, xyzgra_1.dxyz, &ncol, &grad[1], &c__1)
;
if (precis) {
step = .5 / step;
} else {
step = 1. / step;
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L160: */
grad[i__] *= step;
}
/* NOW TO ENSURE THAT INTERNAL DERIVATIVES ACCURATELY REFLECT CARTESIAN */
/* DERIVATIVES */
if (int__ && ! geook && geovar_1.nvar >= molkst_1.numat * 3 - 6 &&
euler_1.id == 0) {
/* NUMBER OF VARIABLES LOOKS O.K. */
sum = dot_(&grad[1], &grad[1], &geovar_1.nvar);
i__1 = molkst_1.numat * 3;
/* Computing MAX */
d__1 = 4., d__2 = sum * 4.;
if (sum < 2. && dot_(xyzgra_1.dxyz, xyzgra_1.dxyz, &i__1) > max(d__1,
d__2)) {
/* OOPS, LOOKS LIKE AN ERROR. */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
j = (integer) (genral_1.xparam[i__ - 1] / 3.141);
if (geovar_1.loc[(i__ << 1) - 1] == 2 && geovar_1.loc[(i__ <<
1) - 2] > 3 && (d__1 = genral_1.xparam[i__ - 1] - j *
3.1415926, abs(d__1)) < .005) {
/* ERROR LOCATED, BUT CANNOT CORRECT IN THIS RUN */
s_wsfe(&io___54);
do_fio(&c__1, " INTERNAL COORDINATE DERIVATIVES DO NOT R"
"EFLECT", (ftnlen)47);
do_fio(&c__1, " CARTESIAN COORDINATE DERIVATIVES", (
ftnlen)33);
do_fio(&c__1, " TO CORRECT ERROR, INCREASE DIHEDRAL OF A"
"TOM", (ftnlen)44);
do_fio(&c__1, (char *)&geovar_1.loc[(i__ << 1) - 2], (
ftnlen)sizeof(integer));
do_fio(&c__1, " BY 90 DEGREES", (ftnlen)14);
e_wsfe();
s_wsfe(&io___55);
do_fio(&c__1, " CURRENT GEOMETRY", (ftnlen)21);
e_wsfe();
geout_(&c__6);
s_stop("", (ftnlen)0);
}
/* L170: */
}
}
}
/* THIS CODE IS ONLY USED IF THE KEYWORD NOANCI IS SPECIFIED */
if (slow) {
if (debug) {
s_wsle(&io___56);
do_lio(&c__9, &c__1, "DOING FULL SCF DERIVATIVES", (ftnlen)26);
e_wsle();
}
deritr_(errfn_1.errfn, &geo[4]);
/* THE ARRAY ERRFN HOLDS THE EXACT DERIVATIVES MINUS THE APPROXIMATE */
/* DERIVATIVES */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L180: */
errfn_1.errfn[i__ - 1] -= grad[i__];
}
}
gravec_1.cosine = dot_(&grad[1], genral_1.gold, &geovar_1.nvar) / sqrt(
dot_(&grad[1], &grad[1], &geovar_1.nvar) * dot_(genral_1.gold,
genral_1.gold, &geovar_1.nvar) + 1e-20);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L190: */
grad[i__] += errfn_1.errfn[i__ - 1];
}
if (aic) {
if (aifrst) {
aifrst = FALSE_;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L200: */
errfn_1.aicorr[i__ - 1] = -aidref[i__ - 1] - grad[i__];
}
}
/* # WRITE(6,'('' GRADIENTS BEFORE AI CORRECTION'')') */
/* # WRITE(6,'(10F8.3)')(GRAD(I),I=1,NVAR) */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L210: */
grad[i__] += errfn_1.aicorr[i__ - 1];
}
}
/* L220: */
if (debug) {
s_wsfe(&io___57);
e_wsfe();
s_wsfe(&io___58);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&grad[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
if (slow) {
s_wsfe(&io___59);
e_wsfe();
s_wsfe(&io___60);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&errfn_1.errfn[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
if (debug) {
s_wsfe(&io___61);
do_fio(&c__1, (char *)&gravec_1.cosine, (ftnlen)sizeof(doublereal));
e_wsfe();
}
return 0;
} /* deriv_ */
/* Subroutine */ int zget36_(doublereal *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static doublecomplex diag[10];
static integer ifst, ilst;
static doublecomplex work[200];
static integer info1, info2, i__, j, n;
static doublecomplex q[100] /* was [10][10] */, ctemp;
extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal rwork[10];
static doublecomplex t1[100] /* was [10][10] */, t2[100] /*
was [10][10] */;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
static doublereal result[2];
extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *);
static doublereal eps, res;
static doublecomplex tmp[100] /* was [10][10] */;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
#define q_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define t1_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define t1_ref(a_1,a_2) t1[t1_subscr(a_1,a_2)]
#define t2_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define t2_ref(a_1,a_2) t2[t2_subscr(a_1,a_2)]
#define tmp_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define tmp_ref(a_1,a_2) tmp[tmp_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a
matrix in complex Schur form. Thus, ZLAEXC computes a unitary matrix
Q such that
Q' * T1 * Q = T2
and where one of the diagonal blocks of T1 (the one at row IFST) has
been moved to position ILST.
The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
is in Schur form, and that the final position of the IFST block is
ILST.
The test matrices are read from a file with logical unit number NIN.
Arguments
==========
RMAX (output) DOUBLE PRECISION
Value of the largest test ratio.
LMAX (output) INTEGER
Example number where largest test ratio achieved.
NINFO (output) INTEGER
Number of examples where INFO is nonzero.
KNT (output) INTEGER
Total number of examples tested.
NIN (input) INTEGER
Input logical unit number.
===================================================================== */
eps = dlamch_("P");
*rmax = 0.;
*lmax = 0;
*knt = 0;
*ninfo = 0;
/* Read input data until N=0 */
L10:
io___2.ciunit = *nin;
s_rsle(&io___2);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
++(*knt);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___7.ciunit = *nin;
s_rsle(&io___7);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&tmp_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
zlacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
zlacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
res = 0.;
/* Test without accumulating Q */
zlaset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ztrexc_("N", &n, t1, &c__10, q, &c__10, &ifst, &ilst, &info1);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = q_subscr(i__, j);
if (i__ == j && (q[i__3].r != 1. || q[i__3].i != 0.)) {
res += 1. / eps;
}
i__3 = q_subscr(i__, j);
if (i__ != j && (q[i__3].r != 0. || q[i__3].i != 0.)) {
res += 1. / eps;
}
/* L30: */
}
/* L40: */
}
/* Test with accumulating Q */
zlaset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ztrexc_("V", &n, t2, &c__10, q, &c__10, &ifst, &ilst, &info2);
/* Compare T1 with T2 */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = t1_subscr(i__, j);
i__4 = t2_subscr(i__, j);
if (t1[i__3].r != t2[i__4].r || t1[i__3].i != t2[i__4].i) {
res += 1. / eps;
}
/* L50: */
}
/* L60: */
}
if (info1 != 0 || info2 != 0) {
++(*ninfo);
}
if (info1 != info2) {
res += 1. / eps;
}
/* Test for successful reordering of T2 */
zcopy_(&n, tmp, &c__11, diag, &c__1);
if (ifst < ilst) {
i__1 = ilst;
for (i__ = ifst + 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__ - 1;
i__3 = i__ - 2;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 2;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L70: */
}
} else if (ifst > ilst) {
i__1 = ilst;
for (i__ = ifst - 1; i__ >= i__1; --i__) {
i__2 = i__;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__;
i__3 = i__ - 1;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 1;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L80: */
}
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = t2_subscr(i__, i__);
i__3 = i__ - 1;
if (t2[i__2].r != diag[i__3].r || t2[i__2].i != diag[i__3].i) {
res += 1. / eps;
}
/* L90: */
}
/* Test for small residual, and orthogonality of Q */
zhst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
rwork, result);
res = res + result[0] + result[1];
/* Test for T2 being in Schur form */
i__1 = n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = t2_subscr(i__, j);
if (t2[i__3].r != 0. || t2[i__3].i != 0.) {
res += 1. / eps;
}
/* L100: */
}
/* L110: */
}
if (res > *rmax) {
*rmax = res;
*lmax = *knt;
}
goto L10;
/* End of ZGET36 */
} /* zget36_ */
/* Main program */ int MAIN__(void)
{
/* Initialized data */
static doublereal threq = 2.;
static char intstr[10] = "0123456789";
/* Format strings */
static char fmt_9994[] = "(\002 Tests of the COMPLEX*16 LAPACK routines"
" \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1,/"
"/\002 The following parameter values will be used:\002)";
static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
"6,\002; must be >=\002,i6)";
static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
"6,\002; must be <=\002,i6)";
static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
"st ratio is \002,\002less than\002,f8.2,/)";
static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
"rors\002)";
static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
" be\002,d16.6)";
static char fmt_9990[] = "(/1x,a3,\002: Unrecognized path name\002)";
static char fmt_9989[] = "(/1x,a3,\002 routines were not tested\002)";
static char fmt_9988[] = "(/1x,a3,\002 driver routines were not teste"
"d\002)";
static char fmt_9998[] = "(/\002 End of tests\002)";
static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
"nds\002,/)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
cilist ci__1;
cllist cl__1;
/* Builtin functions */
integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
char *, ftnlen);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_clos(cllist *);
/* Local variables */
doublecomplex a[153384] /* was [21912][7] */, b[8448] /* was [2112][
4] */;
integer i__, j, k;
doublereal s[264];
char c1[1], c2[2];
doublereal s1, s2;
integer ic, la, nb, nm, nn, vers_patch__, vers_major__, vers_minor__, lda,
nnb;
doublereal eps;
integer nns, nnb2;
char path[3];
integer mval[12], nval[12], nrhs;
doublecomplex work[20856] /* was [132][158] */;
integer lafac;
logical fatal;
char aline[72];
extern logical lsame_(char *, char *);
integer nbval[12], nmats, nsval[12], nxval[12], iwork[3300];
doublereal rwork[19832];
integer nbval2[12];
extern /* Subroutine */ int zchkq3_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, doublecomplex *, doublecomplex *, doublereal *, doublereal *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *);
extern doublereal dlamch_(char *), dsecnd_(void);
extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), zchkgb_(logical *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchkge_(logical *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, logical *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zchkhe_(
logical *, integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int zchkpb_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *), ilaver_(integer *, integer *, integer
*), zchkeq_(doublereal *, integer *), zchktb_(logical *, integer *
, integer *, integer *, integer *, doublereal *, logical *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *), zchkhp_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchkgt_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zchklq_(
logical *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, logical *, integer
*, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *);
doublereal thresh;
extern /* Subroutine */ int zchkpo_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *), zchkpp_(logical *, integer *, integer
*, integer *, integer *, doublereal *, logical *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
logical tstchk;
extern /* Subroutine */ int zchkql_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchkpt_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *, doublereal *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
*, doublecomplex *, doublereal *, integer *);
logical dotype[30];
extern /* Subroutine */ int zchkqp_(logical *, integer *, integer *,
integer *, integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, doublereal *, integer *, integer *), zchkqr_(
logical *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, logical *, integer
*, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *), zchkrq_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchksp_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchktp_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *), zchktr_(logical *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *), zchksy_(logical *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zdrvgb_(logical *, integer *, integer *, integer *,
doublereal *, logical *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublecomplex *, doublereal *, integer *, integer *), zchktz_(
logical *, integer *, integer *, integer *, integer *, doublereal
*, logical *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *, doublecomplex *, doublecomplex *, doublereal *,
integer *), zdrvge_(logical *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *, integer *), zdrvhe_(logical *, integer *
, integer *, integer *, doublereal *, logical *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *), zdrvgt_(logical *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zdrvhp_(
logical *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *, integer *);
integer ntypes;
logical tsterr;
extern /* Subroutine */ int zdrvls_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *, integer *);
logical tstdrv;
extern /* Subroutine */ int zdrvpb_(logical *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *), zdrvpo_(logical *, integer *, integer *
, integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *), zdrvpp_(logical *, integer *, integer *
, integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *), zdrvpt_(logical *, integer *, integer *
, integer *, doublereal *, logical *, doublecomplex *, doublereal
*, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *),
zdrvsp_(logical *, integer *, integer *, integer *, doublereal *,
logical *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zdrvsy_(
logical *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 5, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___11 = { 0, 5, 0, 0, 0 };
static cilist io___13 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___15 = { 0, 5, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___19 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___20 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___21 = { 0, 5, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___24 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___25 = { 0, 5, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___28 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___29 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___30 = { 0, 5, 0, 0, 0 };
static cilist io___32 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___33 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___34 = { 0, 5, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___37 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___39 = { 0, 5, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___42 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___43 = { 0, 5, 0, 0, 0 };
static cilist io___45 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___46 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___51 = { 0, 5, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___55 = { 0, 5, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___58 = { 0, 5, 0, 0, 0 };
static cilist io___60 = { 0, 5, 0, 0, 0 };
static cilist io___62 = { 0, 5, 0, 0, 0 };
static cilist io___64 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___66 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___67 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___69 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___79 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___87 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___89 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___92 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___93 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___95 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___97 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___98 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___99 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___100 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___101 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___102 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___103 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___104 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___105 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___106 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___107 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___108 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___109 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___110 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___111 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___112 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___114 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___116 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___118 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___119 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___120 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___121 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___122 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___123 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___125 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___126 = { 0, 6, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* Purpose */
/* ======= */
/* ZCHKAA is the main test program for the COMPLEX*16 linear equation */
/* routines. */
/* The program must be driven by a short data file. The first 14 records */
/* specify problem dimensions and program options using list-directed */
/* input. The remaining lines specify the LAPACK test paths and the */
/* number of matrix types to use in testing. An annotated example of a */
/* data file can be obtained by deleting the first 3 characters from the */
/* following 38 lines: */
/* Data file for testing COMPLEX*16 LAPACK linear equation routines */
/* 7 Number of values of M */
/* 0 1 2 3 5 10 16 Values of M (row dimension) */
/* 7 Number of values of N */
/* 0 1 2 3 5 10 16 Values of N (column dimension) */
/* 1 Number of values of NRHS */
/* 2 Values of NRHS (number of right hand sides) */
/* 5 Number of values of NB */
/* 1 3 3 3 20 Values of NB (the blocksize) */
/* 1 0 5 9 1 Values of NX (crossover point) */
/* 30.0 Threshold value of test ratio */
/* T Put T to test the LAPACK routines */
/* T Put T to test the driver routines */
/* T Put T to test the error exits */
/* ZGE 11 List types on next line if 0 < NTYPES < 11 */
/* ZGB 8 List types on next line if 0 < NTYPES < 8 */
/* ZGT 12 List types on next line if 0 < NTYPES < 12 */
/* ZPO 9 List types on next line if 0 < NTYPES < 9 */
/* ZPP 9 List types on next line if 0 < NTYPES < 9 */
/* ZPB 8 List types on next line if 0 < NTYPES < 8 */
/* ZPT 12 List types on next line if 0 < NTYPES < 12 */
/* ZHE 10 List types on next line if 0 < NTYPES < 10 */
/* ZHP 10 List types on next line if 0 < NTYPES < 10 */
/* ZSY 11 List types on next line if 0 < NTYPES < 11 */
/* ZSP 11 List types on next line if 0 < NTYPES < 11 */
/* ZTR 18 List types on next line if 0 < NTYPES < 18 */
/* ZTP 18 List types on next line if 0 < NTYPES < 18 */
/* ZTB 17 List types on next line if 0 < NTYPES < 17 */
/* ZQR 8 List types on next line if 0 < NTYPES < 8 */
/* ZRQ 8 List types on next line if 0 < NTYPES < 8 */
/* ZLQ 8 List types on next line if 0 < NTYPES < 8 */
/* ZQL 8 List types on next line if 0 < NTYPES < 8 */
/* ZQP 6 List types on next line if 0 < NTYPES < 6 */
/* ZTZ 3 List types on next line if 0 < NTYPES < 3 */
/* ZLS 6 List types on next line if 0 < NTYPES < 6 */
/* ZEQ */
/* Internal Parameters */
/* =================== */
/* NMAX INTEGER */
/* The maximum allowable value for N. */
/* MAXIN INTEGER */
/* The number of different values that can be used for each of */
/* M, N, or NB */
/* MAXRHS INTEGER */
/* The maximum number of right hand sides */
/* NIN INTEGER */
/* The unit number for input */
/* NOUT INTEGER */
/* The unit number for output */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
s1 = dsecnd_();
lda = 132;
fatal = FALSE_;
/* Read a dummy line. */
s_rsle(&io___6);
e_rsle();
/* Report values of parameters. */
ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
s_wsfe(&io___10);
do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
e_wsfe();
/* Read the values of M */
s_rsle(&io___11);
do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
e_rsle();
if (nm < 1) {
s_wsfe(&io___13);
do_fio(&c__1, " NM ", (ftnlen)4);
do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nm = 0;
fatal = TRUE_;
} else if (nm > 12) {
s_wsfe(&io___14);
do_fio(&c__1, " NM ", (ftnlen)4);
do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nm = 0;
fatal = TRUE_;
}
s_rsle(&io___15);
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
if (mval[i__ - 1] < 0) {
s_wsfe(&io___18);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (mval[i__ - 1] > 132) {
s_wsfe(&io___19);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
if (nm > 0) {
s_wsfe(&io___20);
do_fio(&c__1, "M ", (ftnlen)4);
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of N */
s_rsle(&io___21);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn < 1) {
s_wsfe(&io___23);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
} else if (nn > 12) {
s_wsfe(&io___24);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
}
s_rsle(&io___25);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nval[i__ - 1] < 0) {
s_wsfe(&io___27);
do_fio(&c__1, " N ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nval[i__ - 1] > 132) {
s_wsfe(&io___28);
do_fio(&c__1, " N ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L20: */
}
if (nn > 0) {
s_wsfe(&io___29);
do_fio(&c__1, "N ", (ftnlen)4);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of NRHS */
s_rsle(&io___30);
do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
e_rsle();
if (nns < 1) {
s_wsfe(&io___32);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
} else if (nns > 12) {
s_wsfe(&io___33);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
}
s_rsle(&io___34);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nsval[i__ - 1] < 0) {
s_wsfe(&io___36);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nsval[i__ - 1] > 16) {
s_wsfe(&io___37);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L30: */
}
if (nns > 0) {
s_wsfe(&io___38);
do_fio(&c__1, "NRHS", (ftnlen)4);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of NB */
s_rsle(&io___39);
do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
e_rsle();
if (nnb < 1) {
s_wsfe(&io___41);
do_fio(&c__1, "NNB ", (ftnlen)4);
do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nnb = 0;
fatal = TRUE_;
} else if (nnb > 12) {
s_wsfe(&io___42);
do_fio(&c__1, "NNB ", (ftnlen)4);
do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nnb = 0;
fatal = TRUE_;
}
s_rsle(&io___43);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbval[i__ - 1] < 0) {
s_wsfe(&io___45);
do_fio(&c__1, " NB ", (ftnlen)4);
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L40: */
}
if (nnb > 0) {
s_wsfe(&io___46);
do_fio(&c__1, "NB ", (ftnlen)4);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Set NBVAL2 to be the set of unique values of NB */
nnb2 = 0;
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
nb = nbval[i__ - 1];
i__2 = nnb2;
for (j = 1; j <= i__2; ++j) {
if (nb == nbval2[j - 1]) {
goto L60;
}
/* L50: */
}
++nnb2;
nbval2[nnb2 - 1] = nb;
L60:
;
}
/* Read the values of NX */
s_rsle(&io___51);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nxval[i__ - 1] < 0) {
s_wsfe(&io___53);
do_fio(&c__1, " NX ", (ftnlen)4);
do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L70: */
}
if (nnb > 0) {
s_wsfe(&io___54);
do_fio(&c__1, "NX ", (ftnlen)4);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the threshold value for the test ratios. */
s_rsle(&io___55);
do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___57);
do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the flag that indicates whether to test the LAPACK routines. */
s_rsle(&io___58);
do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
e_rsle();
/* Read the flag that indicates whether to test the driver routines. */
s_rsle(&io___60);
do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
e_rsle();
/* Read the flag that indicates whether to test the error exits. */
s_rsle(&io___62);
do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
e_rsle();
if (fatal) {
s_wsfe(&io___64);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Calculate and print the machine dependent constants. */
eps = dlamch_("Underflow threshold");
s_wsfe(&io___66);
do_fio(&c__1, "underflow", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Overflow threshold");
s_wsfe(&io___67);
do_fio(&c__1, "overflow ", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Epsilon");
s_wsfe(&io___68);
do_fio(&c__1, "precision", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsle(&io___69);
e_wsle();
nrhs = nsval[0];
L80:
/* Read a test path and the number of matrix types to use. */
ci__1.cierr = 0;
ci__1.ciend = 1;
ci__1.ciunit = 5;
ci__1.cifmt = "(A72)";
i__1 = s_rsfe(&ci__1);
if (i__1 != 0) {
goto L140;
}
i__1 = do_fio(&c__1, aline, (ftnlen)72);
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L140;
}
s_copy(path, aline, (ftnlen)3, (ftnlen)3);
nmats = 30;
i__ = 3;
L90:
++i__;
if (i__ > 72) {
goto L130;
}
if (*(unsigned char *)&aline[i__ - 1] == ' ') {
goto L90;
}
nmats = 0;
L100:
*(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
for (k = 1; k <= 10; ++k) {
if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
ic = k - 1;
goto L120;
}
/* L110: */
}
goto L130;
L120:
nmats = nmats * 10 + ic;
++i__;
if (i__ > 72) {
goto L130;
}
goto L100;
L130:
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Check first character for correct precision. */
if (! lsame_(c1, "Zomplex precision")) {
s_wsfe(&io___78);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (nmats <= 0) {
/* Check for a positive number of tests requested. */
s_wsfe(&io___79);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (lsamen_(&c__2, c2, "GE")) {
/* GE: general matrices */
ntypes = 11;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkge_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
&thresh, &tsterr, &lda, a, &a[21912], &a[43824], b, &b[
2112], &b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___87);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvge_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___89);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "GB")) {
/* GB: general banded matrices */
la = 43692;
lafac = 65472;
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkgb_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
&thresh, &tsterr, a, &la, &a[43824], &lafac, b, &b[2112],
&b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___92);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvgb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &la, &a[
43824], &lafac, &a[109560], b, &b[2112], &b[4224], &b[
6336], s, work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___93);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "GT")) {
/* GT: general tridiagonal matrices */
ntypes = 12;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkgt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
21912], b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___94);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvgt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___95);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PO")) {
/* PO: positive definite matrices */
ntypes = 9;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpo_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, &c__6);
} else {
s_wsfe(&io___96);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpo_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, &c__6);
} else {
s_wsfe(&io___97);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PP")) {
/* PP: positive definite packed matrices */
ntypes = 9;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
&c__6);
} else {
s_wsfe(&io___98);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, &c__6);
} else {
s_wsfe(&io___99);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PB")) {
/* PB: positive definite banded matrices */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpb_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, &c__6);
} else {
s_wsfe(&io___100);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, &c__6);
} else {
s_wsfe(&io___101);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PT")) {
/* PT: positive definite tridiagonal matrices */
ntypes = 12;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, s, &
a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___102);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, s, &a[
21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___103);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "HE")) {
/* HE: Hermitian indefinite matrices */
ntypes = 10;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkhe_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___104);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvhe_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___105);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "HP")) {
/* HP: Hermitian indefinite packed matrices */
ntypes = 10;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkhp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___106);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvhp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___107);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "SY")) {
/* SY: symmetric indefinite matrices */
ntypes = 11;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchksy_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___108);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvsy_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___109);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "SP")) {
/* SP: symmetric indefinite packed matrices */
ntypes = 11;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchksp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___110);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvsp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___111);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* TR: triangular matrices */
ntypes = 18;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktr_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], b, &b[2112], &b[4224], work,
rwork, &c__6);
} else {
s_wsfe(&io___112);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TP")) {
/* TP: triangular packed matrices */
ntypes = 18;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___113);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* TB: triangular banded matrices */
ntypes = 17;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktb_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___114);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "QR")) {
/* QR: QR factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkqr_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___115);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "LQ")) {
/* LQ: LQ factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchklq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___116);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "QL")) {
/* QL: QL factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkql_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___117);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "RQ")) {
/* RQ: RQ factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkrq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___118);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "EQ")) {
/* EQ: Equilibration routines for general and positive definite */
/* matrices (THREQ should be between 2 and 10) */
if (tstchk) {
zchkeq_(&threq, &c__6);
} else {
s_wsfe(&io___119);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TZ")) {
/* TZ: Trapezoidal matrix */
ntypes = 3;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktz_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
21912], s, &s[132], b, work, rwork, &c__6);
} else {
s_wsfe(&io___120);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "QP")) {
/* QP: QR factorization with pivoting */
ntypes = 6;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkqp_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
21912], s, &s[132], b, work, rwork, iwork, &c__6);
zchkq3_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &thresh,
a, &a[21912], s, &s[132], b, work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___121);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "LS")) {
/* LS: Least squares drivers */
ntypes = 6;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstdrv) {
zdrvls_(dotype, &nm, mval, &nn, nval, &nns, nsval, &nnb, nbval,
nxval, &thresh, &tsterr, a, &a[21912], &a[43824], &a[
65736], &a[87648], s, &s[132], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___122);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else {
s_wsfe(&io___123);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
/* Go back to get another input line. */
goto L80;
/* Branch to this line when the last record is read. */
L140:
cl__1.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
f_clos(&cl__1);
s2 = dsecnd_();
s_wsfe(&io___125);
e_wsfe();
s_wsfe(&io___126);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* End of ZCHKAA */
return 0;
} /* MAIN__ */
/* Subroutine */ int cget35_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Local variables */
complex a[100] /* was [10][10] */, b[100] /* was [10][10] */,
c__[100] /* was [10][10] */;
integer i__, j, m, n;
real vm1[3], vm2[3], dum[1], eps, res, res1;
integer imla, imlb, imlc, info;
complex csav[100] /* was [10][10] */;
integer isgn;
complex atmp[100] /* was [10][10] */, btmp[100] /* was [10][10] */,
ctmp[100] /* was [10][10] */;
real tnrm;
complex rmul;
real xnrm;
integer imlad;
real scale;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
char trana[1], tranb[1];
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
integer itrana, itranb;
real bignum, smlnum;
extern /* Subroutine */ int ctrsyl_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGET35 tests CTRSYL, a routine for solving the Sylvester matrix */
/* equation */
/* op(A)*X + ISGN*X*op(B) = scale*C, */
/* A and B are assumed to be in Schur canonical form, op() represents an */
/* optional transpose, and ISGN can be -1 or +1. Scale is an output */
/* less than or equal to 1, chosen to avoid overflow in X. */
/* The test code verifies that the following residual is order 1: */
/* norm(op(A)*X + ISGN*X*op(B) - scale*C) / */
/* (EPS*max(norm(A),norm(B))*norm(X)) */
/* Arguments */
/* ========== */
/* RMAX (output) REAL */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER */
/* Number of examples where INFO is nonzero. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Get machine parameters */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Set up test case parameters */
vm1[0] = sqrt(smlnum);
vm1[1] = 1.f;
vm1[2] = 1e6f;
vm2[0] = 1.f;
vm2[1] = eps * 2.f + 1.f;
vm2[2] = 2.f;
*knt = 0;
*ninfo = 0;
*lmax = 0;
*rmax = 0.f;
/* Begin test loop */
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&atmp[i__ + j * 10 - 11], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&btmp[i__ + j * 10 - 11], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L30: */
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&ctmp[i__ + j * 10 - 11], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L40: */
}
for (imla = 1; imla <= 3; ++imla) {
for (imlad = 1; imlad <= 3; ++imlad) {
for (imlb = 1; imlb <= 3; ++imlb) {
for (imlc = 1; imlc <= 3; ++imlc) {
for (itrana = 1; itrana <= 2; ++itrana) {
for (itranb = 1; itranb <= 2; ++itranb) {
for (isgn = -1; isgn <= 1; isgn += 2) {
if (itrana == 1) {
*(unsigned char *)trana = 'N';
}
if (itrana == 2) {
*(unsigned char *)trana = 'C';
}
if (itranb == 1) {
*(unsigned char *)tranb = 'N';
}
if (itranb == 2) {
*(unsigned char *)tranb = 'C';
}
tnrm = 0.f;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = m;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
i__5 = imla - 1;
q__1.r = vm1[i__5] * atmp[i__4].r,
q__1.i = vm1[i__5] * atmp[
i__4].i;
a[i__3].r = q__1.r, a[i__3].i =
q__1.i;
/* Computing MAX */
r__1 = tnrm, r__2 = c_abs(&a[i__ + j *
10 - 11]);
tnrm = dmax(r__1,r__2);
/* L50: */
}
i__2 = i__ + i__ * 10 - 11;
i__3 = i__ + i__ * 10 - 11;
i__4 = imlad - 1;
q__1.r = vm2[i__4] * a[i__3].r, q__1.i =
vm2[i__4] * a[i__3].i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* Computing MAX */
r__1 = tnrm, r__2 = c_abs(&a[i__ + i__ *
10 - 11]);
tnrm = dmax(r__1,r__2);
/* L60: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
i__5 = imlb - 1;
q__1.r = vm1[i__5] * btmp[i__4].r,
q__1.i = vm1[i__5] * btmp[
i__4].i;
b[i__3].r = q__1.r, b[i__3].i =
q__1.i;
/* Computing MAX */
r__1 = tnrm, r__2 = c_abs(&b[i__ + j *
10 - 11]);
tnrm = dmax(r__1,r__2);
/* L70: */
}
/* L80: */
}
if (tnrm == 0.f) {
tnrm = 1.f;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
i__5 = imlc - 1;
q__1.r = vm1[i__5] * ctmp[i__4].r,
q__1.i = vm1[i__5] * ctmp[
i__4].i;
c__[i__3].r = q__1.r, c__[i__3].i =
q__1.i;
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
csav[i__3].r = c__[i__4].r, csav[i__3]
.i = c__[i__4].i;
/* L90: */
}
/* L100: */
}
++(*knt);
ctrsyl_(trana, tranb, &isgn, &m, &n, a, &
c__10, b, &c__10, c__, &c__10, &scale,
&info);
if (info != 0) {
++(*ninfo);
}
xnrm = clange_("M", &m, &n, c__, &c__10, dum);
rmul.r = 1.f, rmul.i = 0.f;
if (xnrm > 1.f && tnrm > 1.f) {
if (xnrm > bignum / tnrm) {
r__1 = dmax(xnrm,tnrm);
rmul.r = r__1, rmul.i = 0.f;
c_div(&q__1, &c_b43, &rmul);
rmul.r = q__1.r, rmul.i = q__1.i;
}
}
r__1 = -scale;
q__1.r = r__1 * rmul.r, q__1.i = r__1 *
rmul.i;
cgemm_(trana, "N", &m, &n, &m, &rmul, a, &
c__10, c__, &c__10, &q__1, csav, &
c__10);
r__1 = (real) isgn;
q__1.r = r__1 * rmul.r, q__1.i = r__1 *
rmul.i;
cgemm_("N", tranb, &m, &n, &n, &q__1, c__, &
c__10, b, &c__10, &c_b43, csav, &
c__10);
res1 = clange_("M", &m, &n, csav, &c__10, dum);
/* Computing MAX */
r__1 = smlnum, r__2 = smlnum * xnrm, r__1 =
max(r__1,r__2), r__2 = c_abs(&rmul) *
tnrm * eps * xnrm;
res = res1 / dmax(r__1,r__2);
if (res > *rmax) {
*lmax = *knt;
*rmax = res;
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* L160: */
}
/* L170: */
}
goto L10;
/* End of CGET35 */
} /* cget35_ */
/* Main program */ int MAIN__(void)
{
/* Format strings */
static char fmt_9994[] = "(/\002 Tests of the DOUBLE PRECISION LAPACK RF"
"P routines \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002"
".\002,i1,//\002 The following parameter values will be used:\002)"
;
static char fmt_9996[] = "(\002 !! Invalid input value: \002,a4,\002="
"\002,i6,\002; must be >=\002,i6)";
static char fmt_9995[] = "(\002 !! Invalid input value: \002,a4,\002="
"\002,i6,\002; must be <=\002,i6)";
static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
"st ratio is \002,\002less than\002,f8.2,/)";
static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
"rors\002)";
static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
" be\002,d16.6)";
static char fmt_9998[] = "(/\002 End of tests\002)";
static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
"nds\002,/)";
/* System generated locals */
integer i__1;
doublereal d__1;
cllist cl__1;
/* Builtin functions */
integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
char *, ftnlen);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), f_clos(cllist *);
/* Local variables */
doublereal workafac[2500] /* was [50][50] */, workasav[2500] /*
was [50][50] */, workbsav[800] /* was [50][16] */, workainv[
2500] /* was [50][50] */, workxact[800] /* was [50][
16] */;
integer i__;
doublereal s1, s2;
integer nn, vers_patch__, vers_major__, vers_minor__;
doublereal workarfinv[1275], eps;
integer nns, nnt, nval[12];
doublereal d_temp_dpot02__[800] /* was [50][16] */, d_temp_dpot03__[
2500] /* was [50][50] */, d_work_dpot01__[50],
d_work_dpot02__[50], d_work_dpot03__[50];
logical fatal;
integer nsval[12], ntval[9];
doublereal worka[2500] /* was [50][50] */, workb[800] /* was [50][
16] */, workx[800] /* was [50][16] */, d_work_dlatms__[150],
d_work_dlansy__[50];
extern doublereal dlamch_(char *), dsecnd_(void);
extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
doublereal thresh, workap[1275];
logical tsterr;
extern /* Subroutine */ int ddrvrf1_(integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *)
, ddrvrf2_(integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, doublereal *), ddrvrf3_(integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), ddrvrf4_(integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *), derrrfp_(
integer *), ddrvrfp_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
doublereal workarf[1275];
/* Fortran I/O blocks */
static cilist io___3 = { 0, 5, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___8 = { 0, 5, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___11 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___12 = { 0, 5, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___16 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___17 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___18 = { 0, 5, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___21 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___25 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___26 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___27 = { 0, 5, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___30 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___31 = { 0, 5, 0, 0, 0 };
static cilist io___33 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___36 = { 0, 5, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 5, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___46 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___47 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* Purpose */
/* ======= */
/* DCHKRFP is the main test program for the DOUBLE PRECISION linear */
/* equation routines with RFP storage format */
/* Internal Parameters */
/* =================== */
/* MAXIN INTEGER */
/* The number of different values that can be used for each of */
/* M, N, or NB */
/* MAXRHS INTEGER */
/* The maximum number of right hand sides */
/* NTYPES INTEGER */
/* NMAX INTEGER */
/* The maximum allowable value for N. */
/* NIN INTEGER */
/* The unit number for input */
/* NOUT INTEGER */
/* The unit number for output */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
s1 = dsecnd_();
fatal = FALSE_;
/* Read a dummy line. */
s_rsle(&io___3);
e_rsle();
/* Report LAPACK version tag (e.g. LAPACK-3.2.0) */
ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
s_wsfe(&io___7);
do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
e_wsfe();
/* Read the values of N */
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn < 1) {
s_wsfe(&io___10);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
} else if (nn > 12) {
s_wsfe(&io___11);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
}
s_rsle(&io___12);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nval[i__ - 1] < 0) {
s_wsfe(&io___15);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nval[i__ - 1] > 50) {
s_wsfe(&io___16);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__50, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
if (nn > 0) {
s_wsfe(&io___17);
do_fio(&c__1, "N ", (ftnlen)4);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of NRHS */
s_rsle(&io___18);
do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
e_rsle();
if (nns < 1) {
s_wsfe(&io___20);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
} else if (nns > 12) {
s_wsfe(&io___21);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
}
s_rsle(&io___22);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nsval[i__ - 1] < 0) {
s_wsfe(&io___24);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nsval[i__ - 1] > 16) {
s_wsfe(&io___25);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L30: */
}
if (nns > 0) {
s_wsfe(&io___26);
do_fio(&c__1, "NRHS", (ftnlen)4);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the matrix types */
s_rsle(&io___27);
do_lio(&c__3, &c__1, (char *)&nnt, (ftnlen)sizeof(integer));
e_rsle();
if (nnt < 1) {
s_wsfe(&io___29);
do_fio(&c__1, " NMA", (ftnlen)4);
do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nnt = 0;
fatal = TRUE_;
} else if (nnt > 9) {
s_wsfe(&io___30);
do_fio(&c__1, " NMA", (ftnlen)4);
do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
e_wsfe();
nnt = 0;
fatal = TRUE_;
}
s_rsle(&io___31);
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ntval[i__ - 1] < 0) {
s_wsfe(&io___33);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (ntval[i__ - 1] > 9) {
s_wsfe(&io___34);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L320: */
}
if (nnt > 0) {
s_wsfe(&io___35);
do_fio(&c__1, "TYPE", (ftnlen)4);
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the threshold value for the test ratios. */
s_rsle(&io___36);
do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___38);
do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the flag that indicates whether to test the error exits. */
s_rsle(&io___39);
do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
e_rsle();
if (fatal) {
s_wsfe(&io___41);
e_wsfe();
s_stop("", (ftnlen)0);
}
if (fatal) {
s_wsfe(&io___42);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Calculate and print the machine dependent constants. */
eps = dlamch_("Underflow threshold");
s_wsfe(&io___44);
do_fio(&c__1, "underflow", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Overflow threshold");
s_wsfe(&io___45);
do_fio(&c__1, "overflow ", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Epsilon");
s_wsfe(&io___46);
do_fio(&c__1, "precision", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsle(&io___47);
e_wsle();
/* Test the error exit of: */
if (tsterr) {
derrrfp_(&c__6);
}
/* Test the routines: dpftrf, dpftri, dpftrs (as in DDRVPO). */
/* This also tests the routines: dtfsm, dtftri, dtfttr, dtrttf. */
ddrvrfp_(&c__6, &nn, nval, &nns, nsval, &nnt, ntval, &thresh, worka,
workasav, workafac, workainv, workb, workbsav, workxact, workx,
workarf, workarfinv, d_work_dlatms__, d_work_dpot01__,
d_temp_dpot02__, d_temp_dpot03__, d_work_dlansy__,
d_work_dpot02__, d_work_dpot03__);
/* Test the routine: dlansf */
ddrvrf1_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf,
d_work_dlansy__);
/* Test the convertion routines: */
/* dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr. */
ddrvrf2_(&c__6, &nn, nval, worka, &c__50, workarf, workap, workasav);
/* Test the routine: dtfsm */
ddrvrf3_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf, workainv,
workafac, d_work_dlansy__, d_work_dpot03__, d_work_dpot01__);
/* Test the routine: dsfrk */
ddrvrf4_(&c__6, &nn, nval, &thresh, worka, workafac, &c__50, workarf,
workainv, &c__50, d_work_dlansy__);
cl__1.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
f_clos(&cl__1);
s2 = dsecnd_();
s_wsfe(&io___67);
e_wsfe();
s_wsfe(&io___68);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* End of DCHKRFP */
return 0;
} /* MAIN__ */
/* Subroutine */ int sget37_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
integer i__, j, m, n;
real s[20], t[400] /* was [20][20] */, v, le[400] /* was [20][20] */,
re[400] /* was [20][20] */, wi[20], wr[20], val[3], dum[1],
eps, sep[20], sin__[20], tol, tmp[400] /* was [20][20] */;
integer ifnd, icmp, iscl, info, lcmp[3], kmin;
real wiin[20], vmax, tnrm, wrin[20], work[1200], vmul, stmp[20];
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real sepin[20], vimin, tolin, vrmin;
integer iwork[40];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real witmp[20], wrtmp[20];
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
logical select[20];
real bignum;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), shseqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, real *, integer *, real *, integer *, integer *)
, strevc_(char *, char *, logical *, integer *, real *, integer *,
real *, integer *, real *, integer *, integer *, integer *, real
*, integer *);
real septmp[20];
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
real smlnum;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, 0, 0 };
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET37 tests STRSNA, a routine for estimating condition numbers of */
/* eigenvalues and/or right eigenvectors of a matrix. */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) REAL array, dimension (3) */
/* Value of the largest test ratio. */
/* RMAX(1) = largest ratio comparing different calls to STRSNA */
/* RMAX(2) = largest error in reciprocal condition */
/* numbers taking their conditioning into account */
/* RMAX(3) = largest error in reciprocal condition */
/* numbers not taking their conditioning into */
/* account (may be larger than RMAX(2)) */
/* LMAX (output) INTEGER array, dimension (3) */
/* LMAX(i) is example number where largest test ratio */
/* RMAX(i) is achieved. Also: */
/* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i */
/* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i */
/* If STRSNA returns INFO nonzero on example i, LMAX(3)=i */
/* NINFO (output) INTEGER array, dimension (3) */
/* NINFO(1) = No. of times SGEHRD returned INFO nonzero */
/* NINFO(2) = No. of times SHSEQR returned INFO nonzero */
/* NINFO(3) = No. of times STRSNA returned INFO nonzero */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ninfo;
--lmax;
--rmax;
/* Function Body */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* EPSIN = 2**(-24) = precision to which input data computed */
eps = dmax(eps,5.9605e-8f);
rmax[1] = 0.f;
rmax[2] = 0.f;
rmax[3] = 0.f;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
*knt = 0;
ninfo[1] = 0;
ninfo[2] = 0;
ninfo[3] = 0;
val[0] = sqrt(smlnum);
val[1] = 1.f;
val[2] = sqrt(bignum);
/* Read input data until N=0. Assume input eigenvalues are sorted */
/* lexicographically (increasing by real part, then decreasing by */
/* imaginary part) */
L10:
io___5.ciunit = *nin;
s_rsle(&io___5);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___8.ciunit = *nin;
s_rsle(&io___8);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
sizeof(real));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = *nin;
s_rsle(&io___11);
do_lio(&c__4, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(real));
e_rsle();
/* L30: */
}
tnrm = slange_("M", &n, &n, tmp, &c__20, work);
/* Begin test */
for (iscl = 1; iscl <= 3; ++iscl) {
/* Scale input matrix */
++(*knt);
slacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
vmul = val[iscl - 1];
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
/* L40: */
}
if (tnrm == 0.f) {
vmul = 1.f;
}
/* Compute eigenvalues and eigenvectors */
i__1 = 1200 - n;
sgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
if (info != 0) {
lmax[1] = *knt;
++ninfo[1];
goto L240;
}
i__1 = n - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
t[i__ + j * 20 - 21] = 0.f;
/* L50: */
}
/* L60: */
}
/* Compute Schur form */
shseqr_("S", "N", &n, &c__1, &n, t, &c__20, wr, wi, dum, &c__1, work,
&c__1200, &info);
if (info != 0) {
lmax[2] = *knt;
++ninfo[2];
goto L240;
}
/* Compute eigenvectors */
strevc_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
&n, &m, work, &info);
/* Compute condition numbers */
strsna_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
s, sep, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
/* Sort eigenvalues and condition numbers lexicographically */
/* to compare with inputs */
scopy_(&n, wr, &c__1, wrtmp, &c__1);
scopy_(&n, wi, &c__1, witmp, &c__1);
scopy_(&n, s, &c__1, stmp, &c__1);
scopy_(&n, sep, &c__1, septmp, &c__1);
r__1 = 1.f / vmul;
sscal_(&n, &r__1, septmp, &c__1);
i__1 = n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
kmin = i__;
vrmin = wrtmp[i__ - 1];
vimin = witmp[i__ - 1];
i__2 = n;
for (j = i__ + 1; j <= i__2; ++j) {
if (wrtmp[j - 1] < vrmin) {
kmin = j;
vrmin = wrtmp[j - 1];
vimin = witmp[j - 1];
}
/* L70: */
}
wrtmp[kmin - 1] = wrtmp[i__ - 1];
witmp[kmin - 1] = witmp[i__ - 1];
wrtmp[i__ - 1] = vrmin;
witmp[i__ - 1] = vimin;
vrmin = stmp[kmin - 1];
stmp[kmin - 1] = stmp[i__ - 1];
stmp[i__ - 1] = vrmin;
vrmin = septmp[kmin - 1];
septmp[kmin - 1] = septmp[i__ - 1];
septmp[i__ - 1] = vrmin;
/* L80: */
}
/* Compare condition numbers for eigenvalues */
/* taking their condition numbers into account */
/* Computing MAX */
r__1 = (real) n * 2.f * eps * tnrm;
v = dmax(r__1,smlnum);
if (tnrm == 0.f) {
v = 1.f;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1]) {
tol = 1.f;
} else {
tol = v / septmp[i__ - 1];
}
if (v > sepin[i__ - 1]) {
tolin = 1.f;
} else {
tolin = v / sepin[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
} else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L90: */
}
/* Compare condition numbers for eigenvectors */
/* taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
tol = septmp[i__ - 1];
} else {
tol = v / stmp[i__ - 1];
}
if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
tolin = sepin[i__ - 1];
} else {
tolin = v / sin__[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
} else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
{
vmax = 1.f / eps;
} else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L100: */
}
/* Compare condition numbers for eigenvalues */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sin__[i__ - 1] <= (real) (n << 1) * eps && stmp[i__ - 1] <= (
real) (n << 1) * eps) {
vmax = 1.f;
} else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = sin__[i__ - 1] / stmp[i__ - 1];
} else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] < stmp[i__ - 1]) {
vmax = stmp[i__ - 1] / sin__[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L110: */
}
/* Compare condition numbers for eigenvectors */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
vmax = 1.f;
} else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = sepin[i__ - 1] / septmp[i__ - 1];
} else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] < septmp[i__ - 1]) {
vmax = septmp[i__ - 1] / sepin[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L120: */
}
/* Compute eigenvalue condition numbers only and compare */
vmax = 0.f;
dum[0] = -1.f;
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L130: */
}
/* Compute eigenvector condition numbers only and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L140: */
}
/* Compute all condition numbers using SELECT and compare */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
select[i__ - 1] = TRUE_;
/* L150: */
}
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
/* L160: */
}
/* Compute eigenvalue condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L170: */
}
/* Compute eigenvector condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L180: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
/* Select first real and first complex eigenvalue */
if (wi[0] == 0.f) {
lcmp[0] = 1;
ifnd = 0;
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] == 0.f) {
select[i__ - 1] = FALSE_;
} else {
ifnd = 1;
lcmp[1] = i__;
lcmp[2] = i__ + 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[20], &c__1);
scopy_(&n, &re[(i__ + 1) * 20 - 20], &c__1, &re[40], &
c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[20], &c__1);
scopy_(&n, &le[(i__ + 1) * 20 - 20], &c__1, &le[40], &
c__1);
}
/* L190: */
}
if (ifnd == 0) {
icmp = 1;
} else {
icmp = 3;
}
} else {
lcmp[0] = 1;
lcmp[1] = 2;
ifnd = 0;
i__1 = n;
for (i__ = 3; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] != 0.f) {
select[i__ - 1] = FALSE_;
} else {
lcmp[2] = i__;
ifnd = 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[40], &c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[40], &c__1);
}
/* L200: */
}
if (ifnd == 0) {
icmp = 2;
} else {
icmp = 3;
}
}
/* Compute all selected condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
/* L210: */
}
/* Compute selected eigenvalue condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L220: */
}
/* Compute selected eigenvector condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
/* L230: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
L240:
;
}
goto L10;
/* End of SGET37 */
} /* sget37_ */
/* $Procedure DAFT2B ( DAF, text to binary ) */
/* Subroutine */ int daft2b_(integer *text, char *binary, integer *resv,
ftnlen binary_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *
, integer, char *, integer);
/* Local variables */
char name__[1000*2];
integer more, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), dafps_(integer *,
integer *, doublereal *, integer *, doublereal *);
char tarch[8];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
integer chunk, isize, lsize;
char ttype[8];
extern /* Subroutine */ int idw2at_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), dafada_(doublereal *, integer *);
doublereal dc[125];
extern /* Subroutine */ int dafbna_(integer *, doublereal *, char *,
ftnlen);
integer ic[250];
extern /* Subroutine */ int dafena_(void);
integer nd;
extern logical failed_(void);
integer ni, handle;
extern /* Subroutine */ int dafcls_(integer *);
char ifname[60*2];
extern /* Subroutine */ int dafopn_(char *, integer *, integer *, char *,
integer *, integer *, ftnlen, ftnlen);
doublereal buffer[1024];
char idword[8];
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
doublereal sum[125];
/* Fortran I/O blocks */
static cilist io___5 = { 1, 0, 1, 0, 0 };
static cilist io___6 = { 1, 0, 1, 0, 0 };
static cilist io___13 = { 1, 0, 1, 0, 0 };
static cilist io___15 = { 1, 0, 1, 0, 0 };
static cilist io___17 = { 1, 0, 1, 0, 0 };
static cilist io___20 = { 1, 0, 1, 0, 0 };
static cilist io___23 = { 1, 0, 1, 0, 0 };
static cilist io___25 = { 1, 0, 1, 0, 0 };
static cilist io___27 = { 1, 0, 1, 0, 0 };
static cilist io___28 = { 1, 0, 1, 0, 0 };
static cilist io___29 = { 1, 0, 1, 0, 0 };
static cilist io___30 = { 1, 0, 1, 0, 0 };
/* $ Abstract */
/* Deprecated. The routine DAFTB supersedes this routine. */
/* NAIF supports this routine only to provide backward */
/* compatibility. */
/* Reconstruct a binary DAF from a text file opened by */
/* the calling program. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TEXT I Logical unit connected to text file. */
/* BINARY I Name of a binary DAF to be created. */
/* RESV I Number of records to reserve. */
/* BSIZE P Buffer size. */
/* $ Detailed_Input */
/* TEXT is a logical unit number, to which a text file has */
/* been connected by the calling program, and into */
/* which the contents of binary DAF have been */
/* written. The file pointer should be placed just */
/* before the file ID word. */
/* BINARY is the name of a binary DAF to be created. */
/* The binary DAF contains the same data as the */
/* text file, but in a form more suitable for use */
/* by application programs. */
/* RESV is the number of records to be reserved in the */
/* binary DAF. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* BSIZE is the size of the buffer used to read array elements */
/* from the text file. No single group of elements should */
/* contains more than BSIZE elements. */
/* $ Exceptions */
/* 1) If for some reason the text file cannot be read, */
/* the error SPICE(DAFREADFAIL) is signalled. */
/* 2) If the architecture of the file is not DAF, as specified by */
/* the ID word, the error SPICE(NOTADAFFILE) will be signalled. */
/* 3) If the text file does not contain matching internal file */
/* names, the error SPICE(DAFNOIFNMATCH) is signalled. */
/* 4) If the text file does not contain matching array names, */
/* the error SPICE(DAFNONAMEMATCH) is signalled. */
/* 5) If the buffer size is not sufficient, the error */
/* SPICE(DAFOVERFLOW) is signalled. */
/* $ Files */
/* See arguments TEXT, BINARY. */
/* $ Particulars */
/* This routine has been made obsolete by the new DAF text to binary */
/* conversion routine DAFTB. This routine remains available for */
/* reasons of backward compatibility. We strongly recommend that you */
/* use the new conversion routines for any new software development. */
/* Please see the header of the routine DAFTB for details. */
/* This routine is necessary for converting older DAF text files into */
/* their equivalent binary formats, as DAFTB uses a different text */
/* file format that is incompatible with the text file format */
/* expected by this routine. */
/* Any binary DAF may be transferred between heterogeneous */
/* Fortran environments by converting it to an equivalent file */
/* containing only ASCII characters. Such a file can be transferred */
/* almost universally, using any number of established protocols */
/* (Kermit, FTP, and so on). Once transferred, the ASCII file can */
/* be reconverted to a binary DAF, using the representations */
/* native to the new host environment. */
/* There are two pairs of routines that can be used to convert */
/* DAFs between binary and ASCII. The first pair, DAFB2A */
/* and DAFA2B, works with complete files. That is, DAFB2A creates */
/* a complete ASCII file containing all of the information in */
/* a particular binary DAF, and nothing else; this file can */
/* be fed directly into DAFA2B to produce a complete binary DAF. */
/* In each case, the names of the files are specified. */
/* A related pair of routines, DAFB2T and DAFT2B, assume that */
/* the ASCII data are to be stored in the midst of a text file. */
/* This allows the calling program to surround the data with */
/* standardized labels, to append several binary DAFs into a */
/* single text file, and so on. */
/* Note that you must select the number of records to be reserved */
/* in the binary DAF. The contents of reserved records are ignored */
/* by the normal transfer process. */
/* $ Examples */
/* DAFB2A and DAFA2B are typically used for simple transfers. */
/* If A.DAF is a binary DAF in environment 1, it can be transferred */
/* to environment 2 in three steps. */
/* 1) Convert it to ASCII: */
/* CALL DAFB2A ( 'A.DAF', 'A.ASCII' ) */
/* 2) Transfer the ASCII file, using FTP, Kermit, or some other */
/* file transfer utility: */
/* ftp> put a.ascii */
/* 3) Convert it to binary on the new machine, */
/* CALL DAFA2B ( 'A.ASCII', 'A.DAF', RESV ) */
/* Note that DAFB2A and DAFA2B work in any standard Fortran-77 */
/* environment. */
/* If the file needs to contain other information---a standard */
/* label, for instance---the first and third steps must be modified */
/* to use DAFB2T and DAFT2B. The first step becomes */
/* (Open a text file) */
/* (Write the label) */
/* CALL DAFB2T ( BINARY, UNIT ) */
/* (Close the text file) */
/* The third step becomes */
/* (Open the text file) */
/* (Read the label) */
/* CALL DAFT2B ( UNIT, BINARY, RESV ) */
/* (Close the text file) */
/* $ Restrictions */
/* DAFT2B cannot be executed while any other DAF is open */
/* for writing. */
/* $ Literature_References */
/* NAIF Document 167.0, "Double Precision Array Files (DAF) */
/* Specification and User's Guide" */
/* $ Author_and_Institution */
/* K. R. Gehringer (JPL) */
/* J.E. McLean (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.1, 26-JUL-2012 (EDW) */
/* Edited Abstract section to use "Deprecated" keyword */
/* and state replacement routine. */
/* Eliminated unneeded Revisions section. */
/* - SPICELIB Version 3.0.0, 04-OCT-1993 (KRG) */
/* Removed the error SPICE(DAFNOIDWORD) as it was no longer */
/* relevant. */
/* Added the error SPICE(NOTADAFFILE) if this routine is called */
/* with a file that does not contain an ID word identifying the */
/* file as a DAF file. */
/* There were no checks of the IOSTAT variable after attempting to */
/* read from the text file, a single test of the IOSTAT variable */
/* was made at the end of the routine. This was not adequate to */
/* detect errors when writing to the text file. So after all of */
/* these read statements, an IF ... END IF block was added to */
/* signal an error if IOSTAT .NE. 0. */
/* IF ( IOSTAT .NE. 0 ) THEN */
/* CALL SETMSG ( 'The attempt to read from file ''#''' // */
/* . ' failed. IOSTAT = #.' ) */
/* CALL ERRFNM ( '#', UNIT ) */
/* CALL SIGERR ( 'SPICE(DAFREADFAIL)' ) */
/* CALL CHKOUT ( 'DAFT2B' ) */
/* RETURN */
/* END IF */
/* Removed the code from the end of the routine that purported to */
/* check for read errors: */
/* C */
/* C If any read screws up, they should all screw up. Why */
/* C make a billion separate checks? */
/* C */
/* IF ( IOSTAT .NE. 0 ) THEN */
/* CALL SETMSG ( 'Value of IOSTAT was: #. ' ) */
/* CALL ERRINT ( '#', IOSTAT ) */
/* CALL SIGERR ( 'SPICE(DAFREADFAIL)' ) */
/* END IF */
/* The answer to the question is: */
/* You have to do a billion separate checks because the IOSTAT */
/* value is only valid for the most recently executed read. */
/* Added a statment to the $ Particulars section to the effect */
/* that this routine has been made obsolete by the introduction of */
/* the routine DAFTB, and that we strongly recommend the use of */
/* the new routine. This routine must, however, be used when */
/* converting older text files to binary, as the old and new */
/* formats are not compatible. */
/* Modified the $ Abstract section to reflect the fact that this */
/* routine is obsolete and maintained for purposes of backward */
/* compatibility only. */
/* - SPICELIB Version 2.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.1, 6-AUG-1990 (HAN) */
/* Header documentation was corrected. This routine will */
/* convert a file containing either ID word, 'NAIF/DAF' or */
/* 'NAIF/NIP'. (Previous versions of SPICELIB software used */
/* the ID word 'NAIF/NIP'.) */
/* - SPICELIB Version 2.0.0, 2-AUG-1990 (JEM) */
/* The previous version of this routine always failed and */
/* signalled the error SPICE(DAFNOIDWORD) because of a faulty */
/* logical expression in an error-checking IF statement. */
/* The error SPICE(DAFNOIDWORD) should be signalled if the */
/* next non-blank line in the text file does not begin with the */
/* word 'NAIF/DAF' AND does not begin with the word 'NAIF/NIP'. */
/* Previously the logic was incorrect causing the error to be */
/* signalled every time no matter what the word was. The */
/* correction consisted of replacing '.OR.' with '.AND.' */
/* in the logical expression. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* text daf to binary */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DAFT2B", (ftnlen)6);
}
s_copy(idword, " ", (ftnlen)8, (ftnlen)1);
s_copy(tarch, " ", (ftnlen)8, (ftnlen)1);
s_copy(ttype, " ", (ftnlen)8, (ftnlen)1);
/* We should be positioned and ready to read the file ID word from */
/* the text file, so let's try it. */
io___5.ciunit = *text;
iostat = s_rsle(&io___5);
if (iostat != 0) {
goto L100001;
}
iostat = do_lio(&c__9, &c__1, idword, (ftnlen)8);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsle();
L100001:
if (iostat != 0) {
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Split the ID word into an architecture and type, and verify that */
/* the architecture is 'DAF'. If it is not, this is the wrong */
/* routine, and an error will be signalled. */
idw2at_(idword, tarch, ttype, (ftnlen)8, (ftnlen)8, (ftnlen)8);
if (s_cmp(tarch, "DAF", (ftnlen)8, (ftnlen)3) != 0) {
setmsg_("File architecture is not 'DAF' for file '#'", (ftnlen)43);
errfnm_("#", text, (ftnlen)1);
sigerr_("SPICE(NOTADAFFILE)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___6.ciunit = *text;
iostat = s_rsle(&io___6);
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__3, &c__1, (char *)&nd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__3, &c__1, (char *)&ni, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__9, &c__1, ifname, (ftnlen)60);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsle();
L100002:
if (iostat != 0) {
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Open the new binary file. */
dafopn_(binary, &nd, &ni, ifname, resv, &handle, binary_len, (ftnlen)60);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Each array is preceded by a '1', which indicates that more */
/* arrays are to come. The array itself begins with the name */
/* and the summary components, and ends with the name again. */
/* The contents are written in arbitrary chunks. The final */
/* chunk is followed by a '0', which indicates that no chunks */
/* remain. The names must match, or the array should not */
/* be terminated normally. */
/* If the chunks in the file are bigger than the local buffer */
/* size, we are in trouble. */
lsize = nd + (ni - 1) / 2 + 1;
isize = lsize << 3;
io___13.ciunit = *text;
iostat = s_rsle(&io___13);
if (iostat != 0) {
goto L100003;
}
iostat = do_lio(&c__3, &c__1, (char *)&more, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100003;
}
iostat = e_rsle();
L100003:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
while(more > 0) {
io___15.ciunit = *text;
iostat = s_rsle(&io___15);
if (iostat != 0) {
goto L100004;
}
iostat = do_lio(&c__9, &c__1, name__, isize);
if (iostat != 0) {
goto L100004;
}
iostat = e_rsle();
L100004:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___17.ciunit = *text;
iostat = s_rsle(&io___17);
if (iostat != 0) {
goto L100005;
}
i__1 = nd;
for (i__ = 1; i__ <= i__1; ++i__) {
iostat = do_lio(&c__5, &c__1, (char *)&dc[(i__2 = i__ - 1) < 125
&& 0 <= i__2 ? i__2 : s_rnge("dc", i__2, "daft2b_", (
ftnlen)465)], (ftnlen)sizeof(doublereal));
if (iostat != 0) {
goto L100005;
}
}
iostat = e_rsle();
L100005:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___20.ciunit = *text;
iostat = s_rsle(&io___20);
if (iostat != 0) {
goto L100006;
}
i__2 = ni - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
iostat = do_lio(&c__3, &c__1, (char *)&ic[(i__1 = i__ - 1) < 250
&& 0 <= i__1 ? i__1 : s_rnge("ic", i__1, "daft2b_", (
ftnlen)480)], (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100006;
}
}
iostat = e_rsle();
L100006:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
dafps_(&nd, &ni, dc, ic, sum);
dafbna_(&handle, sum, name__, isize);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___23.ciunit = *text;
iostat = s_rsle(&io___23);
if (iostat != 0) {
goto L100007;
}
iostat = do_lio(&c__3, &c__1, (char *)&chunk, (ftnlen)sizeof(integer))
;
if (iostat != 0) {
goto L100007;
}
iostat = e_rsle();
L100007:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
while(chunk > 0) {
if (chunk > 1024) {
dafcls_(&handle);
setmsg_("Buffer size exceeded. Increase to #.", (ftnlen)36);
errint_("#", &chunk, (ftnlen)1);
sigerr_("SPICE(DAFOVERFLOW)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} else {
io___25.ciunit = *text;
iostat = s_rsle(&io___25);
if (iostat != 0) {
goto L100008;
}
i__1 = chunk;
for (i__ = 1; i__ <= i__1; ++i__) {
iostat = do_lio(&c__5, &c__1, (char *)&buffer[(i__2 = i__
- 1) < 1024 && 0 <= i__2 ? i__2 : s_rnge("buffer",
i__2, "daft2b_", (ftnlen)533)], (ftnlen)sizeof(
doublereal));
if (iostat != 0) {
goto L100008;
}
}
iostat = e_rsle();
L100008:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTA"
"T = #.", (ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
dafada_(buffer, &chunk);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___27.ciunit = *text;
iostat = s_rsle(&io___27);
if (iostat != 0) {
goto L100009;
}
iostat = do_lio(&c__3, &c__1, (char *)&chunk, (ftnlen)sizeof(
integer));
if (iostat != 0) {
goto L100009;
}
iostat = e_rsle();
L100009:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = "
"#.", (ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___28.ciunit = *text;
iostat = s_rsle(&io___28);
if (iostat != 0) {
goto L100010;
}
iostat = do_lio(&c__9, &c__1, name__ + 1000, isize);
if (iostat != 0) {
goto L100010;
}
iostat = e_rsle();
L100010:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
if (s_cmp(name__, name__ + 1000, isize, isize) != 0) {
dafcls_(&handle);
setmsg_("Array name mismatch: # and #.", (ftnlen)29);
errch_("#", name__, (ftnlen)1, isize);
errch_("#", name__ + 1000, (ftnlen)1, isize);
sigerr_("SPICE(DAFNONAMEMATCH)", (ftnlen)21);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} else {
dafena_();
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___29.ciunit = *text;
iostat = s_rsle(&io___29);
if (iostat != 0) {
goto L100011;
}
iostat = do_lio(&c__3, &c__1, (char *)&more, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100011;
}
iostat = e_rsle();
L100011:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
/* The final '0' indicates that no arrays remain. The first shall */
/* be last: the internal file name brings up the rear. If it doesn't */
/* match the one at the front, complain. */
io___30.ciunit = *text;
iostat = s_rsle(&io___30);
if (iostat != 0) {
goto L100012;
}
iostat = do_lio(&c__9, &c__1, ifname + 60, (ftnlen)60);
if (iostat != 0) {
goto L100012;
}
iostat = e_rsle();
L100012:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
if (s_cmp(ifname, ifname + 60, (ftnlen)60, (ftnlen)60) != 0) {
dafcls_(&handle);
setmsg_("Internal file name mismatch: # and #", (ftnlen)36);
errch_("#", ifname, (ftnlen)1, (ftnlen)60);
errch_("#", ifname + 60, (ftnlen)1, (ftnlen)60);
sigerr_("SPICE(DAFNOIFNMATCH)", (ftnlen)20);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Close the DAF file we just created. */
dafcls_(&handle);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} /* daft2b_ */
/* Subroutine */ int inital_()
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rsle(), do_lio(), e_rsle();
double atan(), sin(), cos();
/* Local variables */
static integer i__, j;
/* Fortran I/O blocks */
static cilist io___17 = { 0, 5, 0, 0, 0 };
static cilist io___18 = { 0, 5, 0, 0, 0 };
static cilist io___19 = { 0, 5, 0, 0, 0 };
static cilist io___20 = { 0, 5, 0, 0, 0 };
static cilist io___21 = { 0, 5, 0, 0, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___23 = { 0, 5, 0, 0, 0 };
static cilist io___24 = { 0, 5, 0, 0, 0 };
static cilist io___25 = { 0, 5, 0, 0, 0 };
/* INITIALIZE CONSTANTS AND ARRAYS */
/* R. K. SATO 4/7/86 */
/* NOTE BELOW THAT TWO DELTA T (TDT) IS SET TO DT ON THE FIRST */
/* CYCLE AFTER WHICH IT IS RESET TO DT+DT. */
/* The following code was in SWM256, however, it was replaced by */
/* READ statements to avoid calculations to be done during */
/* compile time. */
/* DT = 20. */
/* DX = .25E5 */
/* DY = .25E5 */
/* A = 1.E6 */
/* ALPHA = .001 */
/* ITMAX = 1200 */
/* MPRINT = 1200 */
/* M = N1 - 1 */
/* N = N2 - 1 */
s_rsle(&io___17);
do_lio(&c__5, &c__1, (char *)&cons_1.dt, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___18);
do_lio(&c__5, &c__1, (char *)&cons_1.dx, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___19);
do_lio(&c__5, &c__1, (char *)&cons_1.dy, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___20);
do_lio(&c__5, &c__1, (char *)&cons_1.a, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___21);
do_lio(&c__5, &c__1, (char *)&cons_1.alpha, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___22);
do_lio(&c__3, &c__1, (char *)&cons_1.itmax, (ftnlen)sizeof(integer));
e_rsle();
s_rsle(&io___23);
do_lio(&c__3, &c__1, (char *)&cons_1.mprint, (ftnlen)sizeof(integer));
e_rsle();
s_rsle(&io___24);
do_lio(&c__3, &c__1, (char *)&cons_1.m, (ftnlen)sizeof(integer));
e_rsle();
s_rsle(&io___25);
do_lio(&c__3, &c__1, (char *)&cons_1.n, (ftnlen)sizeof(integer));
e_rsle();
cons_1.tdt = cons_1.dt;
cons_1.mp1 = cons_1.m + 1;
cons_1.np1 = cons_1.n + 1;
cons_1.el = cons_1.n * cons_1.dx;
cons_1.pi = atan(1.) * 4.;
cons_1.tpi = cons_1.pi + cons_1.pi;
cons_1.di = cons_1.tpi / cons_1.m;
cons_1.dj = cons_1.tpi / cons_1.n;
cons_1.pcf = cons_1.pi * cons_1.pi * cons_1.a * cons_1.a / (cons_1.el *
cons_1.el);
/* INITIAL VALUES OF THE STREAM FUNCTION AND P */
i__1 = cons_1.np1;
for (j = 1; j <= i__1; ++j) {
i__2 = cons_1.mp1;
for (i__ = 1; i__ <= i__2; ++i__) {
_BLNK__1.psi[i__ + j * 1335 - 1336] = cons_1.a * sin((i__ - .5) *
cons_1.di) * sin((j - .5) * cons_1.dj);
_BLNK__1.p[i__ + j * 1335 - 1336] = cons_1.pcf * (cos((i__ - 1) *
2. * cons_1.di) + cos((j - 1) * 2. * cons_1.dj)) + 5e4;
/* L50: */
}
}
/* INITIALIZE VELOCITIES */
i__2 = cons_1.n;
#pragma omp parallel for
for (j = 1; j <= i__2; ++j) {
i__1 = cons_1.m;
for (i__ = 1; i__ <= i__1; ++i__) {
_BLNK__1.u[i__ + 1 + j * 1335 - 1336] = -(_BLNK__1.psi[i__ + 1 + (
j + 1) * 1335 - 1336] - _BLNK__1.psi[i__ + 1 + j * 1335 -
1336]) / cons_1.dy;
_BLNK__1.v[i__ + (j + 1) * 1335 - 1336] = (_BLNK__1.psi[i__ + 1 +
(j + 1) * 1335 - 1336] - _BLNK__1.psi[i__ + (j + 1) *
1335 - 1336]) / cons_1.dx;
/* L60: */
}
}
/* PERIODIC CONTINUATION */
i__1 = cons_1.n;
#pragma omp parallel for
for (j = 1; j <= i__1; ++j) {
_BLNK__1.u[j * 1335 - 1335] = _BLNK__1.u[cons_1.m + 1 + j * 1335 -
1336];
_BLNK__1.v[cons_1.m + 1 + (j + 1) * 1335 - 1336] = _BLNK__1.v[(j + 1)
* 1335 - 1335];
/* L70: */
}
i__1 = cons_1.m;
for (i__ = 1; i__ <= i__1; ++i__) {
_BLNK__1.u[i__ + 1 + (cons_1.n + 1) * 1335 - 1336] = _BLNK__1.u[i__];
_BLNK__1.v[i__ - 1] = _BLNK__1.v[i__ + (cons_1.n + 1) * 1335 - 1336];
/* L75: */
}
_BLNK__1.u[(cons_1.n + 1) * 1335 - 1335] = _BLNK__1.u[cons_1.m];
_BLNK__1.v[cons_1.m] = _BLNK__1.v[(cons_1.n + 1) * 1335 - 1335];
i__1 = cons_1.np1;
for (j = 1; j <= i__1; ++j) {
i__2 = cons_1.mp1;
for (i__ = 1; i__ <= i__2; ++i__) {
_BLNK__1.uold[i__ + j * 1335 - 1336] = _BLNK__1.u[i__ + j * 1335
- 1336];
_BLNK__1.vold[i__ + j * 1335 - 1336] = _BLNK__1.v[i__ + j * 1335
- 1336];
_BLNK__1.pold[i__ + j * 1335 - 1336] = _BLNK__1.p[i__ + j * 1335
- 1336];
/* L86: */
}
}
/* END OF INITIALIZATION */
return 0;
} /* inital_ */
/* Subroutine */ int zdrgvx_(integer *nsize, doublereal *thresh, integer *nin,
integer *nout, doublecomplex *a, integer *lda, doublecomplex *b,
doublecomplex *ai, doublecomplex *bi, doublecomplex *alpha,
doublecomplex *beta, doublecomplex *vl, doublecomplex *vr, integer *
ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal
*s, doublereal *dtru, doublereal *dif, doublereal *diftru,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *
iwork, integer *liwork, doublereal *result, logical *bwork, integer *
info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
"WY=\002,i5)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Expert Eigenvalue/vect"
"or\002,\002 problem driver\002)";
static char fmt_9995[] = "(\002 Matrix types: \002,/)";
static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
" \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
"\002 YH and X are left and right eigenvectors. \002,/)";
static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
"tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
" \002,/\002 YH and X are left and right eigenvectors. \002,/)"
;
static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
"pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
"ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
" max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
" ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
"Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
"DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
"ors\002,/)";
static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,1p,d10.3)";
static char fmt_9987[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
")\002)";
static char fmt_9986[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
"le #\002,i2,\002)\002)";
static char fmt_9996[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, n, iwa, iwb;
doublereal ulp;
integer iwx, iwy, nmax, linfo;
doublereal anorm, bnorm;
extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *);
integer nerrs;
doublereal ratio1, ratio2, thrsh2;
extern /* Subroutine */ int zlatm6_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal abnorm;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
doublecomplex weight[5];
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
integer minwrk, maxwrk, iptype;
extern /* Subroutine */ int zggevx_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublecomplex *, integer *, doublereal *, integer *,
logical *, integer *);
doublereal ulpinv;
integer nptknt, ntestt;
/* Fortran I/O blocks */
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___35 = { 0, 0, 1, 0, 0 };
static cilist io___36 = { 0, 0, 0, 0, 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, 0, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRGVX checks the nonsymmetric generalized eigenvalue problem */
/* expert driver ZGGEVX. */
/* ZGGEVX computes the generalized eigenvalues, (optionally) the left */
/* and/or right eigenvectors, (optionally) computes a balancing */
/* transformation to improve the conditioning, and (optionally) */
/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
/* When ZDRGVX is called with NSIZE > 0, two types of test matrix pairs */
/* are generated by the subroutine DLATM6 and test the driver ZGGEVX. */
/* The test matrices have the known exact condition numbers for */
/* eigenvalues. For the condition numbers of the eigenvectors */
/* corresponding the first and last eigenvalues are also know */
/* ``exactly'' (see ZLATM6). */
/* For each matrix pair, the following tests will be performed and */
/* compared with the threshhold THRESH. */
/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* (3) The condition number S(i) of eigenvalues computed by ZGGEVX */
/* differs less than a factor THRESH from the exact S(i) (see */
/* ZLATM6). */
/* (4) DIF(i) computed by ZTGSNA differs less than a factor 10*THRESH */
/* from the exact value (for the 1st and 5th vectors only). */
/* Test Matrices */
/* ============= */
/* Two kinds of test matrix pairs */
/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
/* are used in the tests: */
/* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
/* 0 2+a 0 0 0 0 1 0 0 0 */
/* 0 0 3+a 0 0 0 0 1 0 0 */
/* 0 0 0 4+a 0 0 0 0 1 0 */
/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
/* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
/* 1 1 0 0 0 0 1 0 0 0 */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1+a 1+b 0 0 0 1 0 */
/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
/* In both cases the same inverse(YH) and inverse(X) are used to compute */
/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
/* 0 1 -y y -y 0 1 x -x -x */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1 0 0 0 0 1 0 */
/* 0 0 0 0 1, 0 0 0 0 1 , where */
/* a, b, x and y will have all values independently of each other from */
/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
/* Arguments */
/* ========= */
/* NSIZE (input) INTEGER */
/* The number of sizes of matrices to use. NSIZE must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIN will be */
/* tested. If it is not zero, then N = 5. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIN (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
/* It must be at least 1 and at least NSIZE. */
/* B (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, B contains the last matrix actually used. */
/* AI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Copy of A, modified by ZGGEVX. */
/* BI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Copy of B, modified by ZGGEVX. */
/* ALPHA (workspace) COMPLEX*16 array, dimension (NSIZE) */
/* BETA (workspace) COMPLEX*16 array, dimension (NSIZE) */
/* On exit, ALPHA/BETA are the eigenvalues. */
/* VL (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* VL holds the left eigenvectors computed by ZGGEVX. */
/* VR (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* VR holds the right eigenvectors computed by ZGGEVX. */
/* ILO (output/workspace) INTEGER */
/* IHI (output/workspace) INTEGER */
/* LSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* RSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* S (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DIF (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DIFTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* Leading dimension of WORK. LWORK >= 2*N*N + 2*N */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (6*N) */
/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
/* LIWORK (input) INTEGER */
/* Leading dimension of IWORK. LIWORK >= N+2. */
/* RESULT (output/workspace) DOUBLE PRECISION array, dimension (4) */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
vr_dim1 = *lda;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *lda;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--alpha;
--beta;
--lscale;
--rscale;
--s;
--dtru;
--dif;
--diftru;
--work;
--rwork;
--iwork;
--result;
--bwork;
/* Function Body */
*info = 0;
nmax = 5;
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < nmax) {
*info = -6;
} else if (*liwork < nmax + 2) {
*info = -26;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = (nmax << 1) * (nmax + 1);
maxwrk = nmax * (ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &c__1, &nmax, &
c__0) + 1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (nmax << 1) * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGVX", &i__1);
return 0;
}
n = 5;
ulp = dlamch_("P");
ulpinv = 1. / ulp;
thrsh2 = *thresh * 10.;
nerrs = 0;
nptknt = 0;
ntestt = 0;
if (*nsize == 0) {
goto L90;
}
/* Parameters used for generating test matrices. */
d__1 = sqrt(sqrt(ulp));
z__1.r = d__1, z__1.i = 0.;
weight[0].r = z__1.r, weight[0].i = z__1.i;
weight[1].r = .1, weight[1].i = 0.;
weight[2].r = 1., weight[2].i = 0.;
z_div(&z__1, &c_b11, &weight[1]);
weight[3].r = z__1.r, weight[3].i = z__1.i;
z_div(&z__1, &c_b11, weight);
weight[4].r = z__1.r, weight[4].i = z__1.i;
for (iptype = 1; iptype <= 2; ++iptype) {
for (iwa = 1; iwa <= 5; ++iwa) {
for (iwb = 1; iwb <= 5; ++iwb) {
for (iwx = 1; iwx <= 5; ++iwx) {
for (iwy = 1; iwy <= 5; ++iwy) {
/* generated a pair of test matrix */
zlatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
b_offset], &vr[vr_offset], lda, &vl[vl_offset]
, lda, &weight[iwa - 1], &weight[iwb - 1], &
weight[iwx - 1], &weight[iwy - 1], &dtru[1], &
diftru[1]);
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
, lda);
zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
, lda);
zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
bi[bi_offset], lda, &alpha[1], &beta[1], &vl[
vl_offset], lda, &vr[vr_offset], lda, ilo,
ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &
s[1], &dif[1], &work[1], lwork, &rwork[1], &
iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
goto L30;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
&n);
zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
n + 1], &n);
i__1 = n << 1;
abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &
rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.;
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
lda, &vl[vl_offset], lda, &alpha[1], &beta[1],
&work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
result[2] = 0.;
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
lda, &vr[vr_offset], lda, &alpha[1], &beta[1]
, &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.) {
if (dtru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (dtru[i__] == 0.) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)),
d__4 = (d__2 = s[i__] / dtru[i__],
abs(d__2));
rwork[i__] = max(d__3,d__4);
/* Computing MAX */
d__1 = result[3], d__2 = rwork[i__];
result[3] = max(d__1,d__2);
}
/* L10: */
}
/* Test (4) */
result[4] = 0.;
if (dif[1] == 0.) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)),
d__4 = (d__2 = dif[1] / diftru[1], abs(
d__2));
ratio1 = max(d__3,d__4);
/* Computing MAX */
d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)),
d__4 = (d__2 = dif[5] / diftru[5], abs(
d__2));
ratio2 = max(d__3,d__4);
result[4] = max(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2 && j >= 4 || result[j] >=
*thresh && j <= 3) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "ZXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___29.ciunit = *nout;
s_wsfe(&io___29);
e_wsfe();
io___30.ciunit = *nout;
s_wsfe(&io___30);
e_wsfe();
io___31.ciunit = *nout;
s_wsfe(&io___31);
e_wsfe();
/* Tests performed */
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
}
/* L20: */
}
L30:
/* L40: */
;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
goto L150;
L90:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
io___35.ciunit = *nin;
i__1 = s_rsle(&io___35);
if (i__1 != 0) {
goto L150;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L150;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L150;
}
if (n == 0) {
goto L150;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___36.ciunit = *nin;
s_rsle(&io___36);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L100: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___37.ciunit = *nin;
s_rsle(&io___37);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L110: */
}
io___38.ciunit = *nin;
s_rsle(&io___38);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&dtru[i__], (ftnlen)sizeof(doublereal));
}
e_rsle();
io___39.ciunit = *nin;
s_rsle(&io___39);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(doublereal))
;
}
e_rsle();
++nptknt;
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
&alpha[1], &beta[1], &vl[vl_offset], lda, &vr[vr_offset], lda,
ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &s[1], &dif[1],
&work[1], lwork, &rwork[1], &iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L140;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
i__1 = n << 1;
abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.;
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
result[2] = 0.;
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
, lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.) {
if (dtru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (dtru[i__] == 0.) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)), d__4 = (d__2 = s[
i__] / dtru[i__], abs(d__2));
rwork[i__] = max(d__3,d__4);
/* Computing MAX */
d__1 = result[3], d__2 = rwork[i__];
result[3] = max(d__1,d__2);
}
/* L120: */
}
/* Test (4) */
result[4] = 0.;
if (dif[1] == 0.) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)), d__4 = (d__2 = dif[1] /
diftru[1], abs(d__2));
ratio1 = max(d__3,d__4);
/* Computing MAX */
d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)), d__4 = (d__2 = dif[5] /
diftru[5], abs(d__2));
ratio2 = max(d__3,d__4);
result[4] = max(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "ZXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___44.ciunit = *nout;
s_wsfe(&io___44);
e_wsfe();
/* Tests performed */
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
/* L130: */
}
L140:
goto L90;
L150:
/* Summary */
alasvm_("ZXV", nout, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGVX */
} /* zdrgvx_ */
/* Main program */ MAIN__(void)
{
/* Format strings */
static char fmt_9983[] = "(\002 LAPACK VERSION 3.0, released June 30, 19"
"99 \002,/)";
static char fmt_9992[] = "(\002 The following parameter values will be u"
"sed:\002)";
static char fmt_9999[] = "(\002 Too many values of \002,a,\002 using "
"\002,a,\002 = \002,i2)";
static char fmt_9991[] = "(4x,a7,1x,10i6,/12x,10i6)";
static char fmt_9997[] = "(\002 *** \002,a1,\002 = \002,i7,\002 is too b"
"ig: \002,\002maximum allowed is\002,i7)";
static char fmt_9998[] = "(\002 *** LDA = \002,i7,\002 is too small, mus"
"t have \002,\002LDA > 0.\002)";
static char fmt_9995[] = "(\002 *** LDA*N is too big for the dense routi"
"nes \002,\002(LDA =\002,i6,\002, N =\002,i6,\002)\002,/\002 --> "
"Increase LA to at least \002,i8)";
static char fmt_9994[] = "(\002 *** (LDA+K)*M is too big for the band ro"
"utines \002,\002(LDA=\002,i6,\002, M=\002,i6,\002, K=\002,i6,"
"\002)\002,/\002 --> Increase LA to at least \002,i8)";
static char fmt_9996[] = "(\002 *** N*NB is too big for N =\002,i6,\002,"
" NB =\002,i6,/\002 --> Increase LA to at least \002,i8)";
static char fmt_9984[] = "(/\002 Tests not done due to input errors\002)";
static char fmt_9993[] = "(\002 The minimum time a subroutine will be ti"
"med = \002,f6.3,\002 seconds\002)";
static char fmt_9990[] = "(/\002 ------------------------------\002,/"
"\002 >>>>> Sample BLAS <<<<<\002,/\002 ------------------"
"------------\002)";
static char fmt_9989[] = "(1x,a6,\002 not timed due to input errors\002,"
"/)";
static char fmt_9988[] = "(/\002 ------------------------------\002,/"
"\002 >>>>> Timing data <<<<<\002,/\002 ------------------"
"------------\002)";
static char fmt_9987[] = "(1x,a6,\002: Unrecognized path or subroutine "
"name\002,/)";
static char fmt_9986[] = "(\002 End of tests\002)";
static char fmt_9985[] = "(\002 Total time used = \002,f12.2,\002 seco"
"nds\002)";
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), s_rsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_rsfe(void), s_rsle(cilist *), do_lio(integer
*, integer *, char *, ftnlen), e_rsle(void), s_wsle(cilist *),
e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer need, nlda;
static logical blas;
static char line[80];
static integer kval[6], mval[6], maxk, nval[6], maxm, maxn;
static real work[280576] /* was [512][548] */, a[817152] /* was [
272384][3] */, b[817152] /* was [272384][3] */, d__[2048]
/* was [1024][2] */;
static integer i__, l;
static real s[1024];
static logical ldaok;
extern logical lsame_(char *, char *);
static integer nbval[6], maxnb, mkmax;
static char c1[1], c2[2], c3[3];
static integer nxval[6], i2, j2, iwork[10000];
static real s1, s2;
extern /* Subroutine */ int stimb2_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
integer *, integer *, integer *, ftnlen), stimb3_(char *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, real *, real *, integer *,
integer *, integer *, ftnlen), stimq3_(char *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, real *, real *, real *, real *, real *, integer *, real *,
integer *, integer *, integer *, ftnlen);
static integer nk, nm, nn, ldaval[4];
static logical ldamok, ldanok;
static integer maxlda;
extern doublereal second_(void);
extern logical lsamen_(integer *, char *, char *);
static real flptbl[1088640], opctbl[1088640];
extern /* Subroutine */ int stimgb_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, integer *, real *, integer *
, integer *, integer *, integer *, ftnlen), stimge_(char *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, integer *, integer *, integer *, ftnlen);
static real timtbl[1088640], timmin;
extern /* Subroutine */ int stimpb_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, integer *, real *, integer *
, integer *, integer *, integer *, ftnlen);
static logical nxnbok;
extern /* Subroutine */ int stimbr_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, real *, real *, real *,
real *, integer *, integer *, integer *, integer *, ftnlen),
stimtb_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, real *, real *
, real *, integer *, integer *, integer *, integer *, ftnlen),
stimtd_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen), stimhr_(char *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
real *, integer *, integer *, integer *, integer *, ftnlen),
stimgt_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, real *,
integer *, integer *, integer *, integer *, ftnlen), stimmm_(char
*, char *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, real *, integer *, integer *, integer *,
ftnlen, ftnlen), stimlq_(char *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *, integer *, integer *, ftnlen), stimql_(char
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, real *, real *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, ftnlen), stimls_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, real *, integer *,
integer *, ftnlen);
static real reslts[6912] /* was [6][6][8][24] */;
extern /* Subroutine */ int stimpo_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, integer *, real *, integer *, integer *, integer *
, integer *, ftnlen), stimpp_(char *, integer *, integer *,
integer *, integer *, integer *, real *, real *, real *, integer *
, real *, integer *, integer *, integer *, integer *, ftnlen),
stimmv_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, real *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *, ftnlen), stimpt_(char *,
integer *, integer *, integer *, integer *, integer *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, ftnlen), stimqp_(char *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
integer *, real *, integer *, integer *, integer *, ftnlen),
stimqr_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
real *, real *, real *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen), stimrq_(char *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, integer *, real *, real *, real *, real *
, real *, real *, integer *, integer *, integer *, integer *,
ftnlen), stimsp_(char *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, real *, integer *, real *,
integer *, integer *, integer *, integer *, ftnlen), stimtp_(char
*, integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, integer *, integer *, integer *, integer *
, ftnlen), stimtr_(char *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, integer *, integer *, integer *, integer *
, ftnlen), stimsy_(char *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, integer *,
integer *, integer *, ftnlen);
static integer nnb;
static logical mok, nok;
static integer ldr1, ldr2, ldr3;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 6, 0, fmt_9983, 0 };
static cilist io___6 = { 0, 5, 0, "( A80 )", 0 };
static cilist io___10 = { 0, 6, 0, "( 1X, A, / )", 0 };
static cilist io___11 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___12 = { 0, 5, 0, 0, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___15 = { 0, 5, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___21 = { 0, 6, 0, fmt_9997, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 5, 0, 0, 0 };
static cilist io___25 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___26 = { 0, 5, 0, 0, 0 };
static cilist io___28 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 6, 0, 0, 0 };
static cilist io___33 = { 0, 5, 0, 0, 0 };
static cilist io___35 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 5, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 5, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 5, 0, 0, 0 };
static cilist io___47 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___49 = { 0, 5, 0, 0, 0 };
static cilist io___50 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___51 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___52 = { 0, 5, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___55 = { 0, 5, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___60 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___61 = { 0, 6, 0, 0, 0 };
static cilist io___64 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___66 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___69 = { 0, 6, 0, fmt_9984, 0 };
static cilist io___70 = { 0, 6, 0, 0, 0 };
static cilist io___71 = { 0, 6, 0, 0, 0 };
static cilist io___72 = { 0, 5, 0, 0, 0 };
static cilist io___74 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 5, 1, "(A)", 0 };
static cilist io___77 = { 0, 5, 1, "(A)", 0 };
static cilist io___78 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___83 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___84 = { 0, 5, 1, "(A)", 0 };
static cilist io___85 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___89 = { 0, 6, 0, fmt_9987, 0 };
static cilist io___92 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___93 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___101 = { 0, 6, 0, fmt_9987, 0 };
static cilist io___102 = { 0, 5, 1, "(A)", 0 };
static cilist io___104 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___105 = { 0, 6, 0, fmt_9985, 0 };
#define a_ref(a_1,a_2) a[(a_2)*272384 + a_1 - 272385]
#define b_ref(a_1,a_2) b[(a_2)*272384 + a_1 - 272385]
#define d___ref(a_1,a_2) d__[(a_2)*1024 + a_1 - 1025]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
STIMAA is the timing program for the REAL LAPACK
routines. This program collects performance data for the factor,
solve, and inverse routines used in solving systems of linear
equations, and also for the orthogonal factorization and reduction
routines used in solving least squares problems and matrix eigenvalue
problems.
The subprograms call a REAL function SECOND with no
arguments which is assumed to return the central-processor time in
seconds from some fixed starting time.
The program is driven by a short data file, which specifies values
for the matrix dimensions M, N and K, for the blocking parameters
NB and NX, and for the leading array dimension LDA. A minimum time
for each subroutine is included for timing small problems or for
obtaining results on a machine with an inaccurate SECOND function.
The matrix dimensions M, N, and K correspond to the three dimensions
m, n, and k in the Level 3 BLAS. When timing the LAPACK routines for
square matrices, M and N correspond to the matrix dimensions m and n,
and K is the number of right-hand sides (nrhs) for the solves. When
timing the LAPACK routines for band matrices, M is the matrix order
m, N is the half-bandwidth (kl, ku, or kd in the LAPACK notation),
and K is again the number of right-hand sides.
The first 13 records of the data file are read using list-directed
input. The first line of input is printed as the first line of
output and can be used to identify different sets of results. To
assist with debugging an input file, the values are printed out as
they are read in.
The following records are read using the format (A). For these
records, the first 6 characters are reserved for the path or
subroutine name. If a path name is used, the characters after the
path name indicate the routines in the path to be timed, where
'T' or 't' means 'Time this routine'. If the line is blank after the
path name, all routines in the path are timed. If fewer characters
appear than routines in a path, the remaining characters are assumed
to be 'F'. For example, the following 3 lines are equivalent ways of
requesting timing of SGETRF:
SGE T F F
SGE T
SGETRF
An annotated example of a data file can be obtained by deleting the
first 3 characters from the following 30 lines:
LAPACK timing, REAL square matrices
5 Number of values of M
100 200 300 400 500 Values of M (row dimension)
5 Number of values of N
100 200 300 400 500 Values of N (column dimension)
2 Number of values of K
100 400 Values of K
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
2 Number of values of LDA
512 513 Values of LDA (leading dimension)
0.0 Minimum time in seconds
SGE T T T
SPO T T T
SPP T T T
SSY T T T
SSP T T T
STR T T
STP T T
SQR T T F
SLQ T T F
SQL T T F
SRQ T T F
SQP T
SHR T T F F
STD T T F F
SBR T F F
SLS T T T T T T
The routines are timed for all combinations of applicable values of
M, N, K, NB, NX, and LDA, and for all combinations of options such as
UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for
INCX. Certain subroutines, such as the QR factorization, treat the
values of M and N as ordered pairs and operate on M x N matrices.
Internal Parameters
===================
NMAX INTEGER
The maximum value of M or N for square matrices.
LDAMAX INTEGER
The maximum value of LDA.
NMAXB INTEGER
The maximum value of N for band matrices.
MAXVAL INTEGER
The maximum number of values that can be read in for M, N,
K, NB, or NX.
MXNLDA INTEGER
The maximum number of values that can be read in for LDA.
NIN INTEGER
The unit number for input. Currently set to 5 (std input).
NOUT INTEGER
The unit number for output. Currently set to 6 (std output).
===================================================================== */
s1 = second_();
ldr1 = 6;
ldr2 = 6;
ldr3 = 8;
s_wsfe(&io___5);
e_wsfe();
/* Read the first line. The first four characters must be 'BLAS'
for the BLAS data file format to be used. Otherwise, the LAPACK
data file format is assumed. */
s_rsfe(&io___6);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
blas = lsamen_(&c__4, line, "BLAS");
/* Find the last non-blank and print the first line of input as the
first line of output. */
for (l = 80; l >= 1; --l) {
if (*(unsigned char *)&line[l - 1] != ' ') {
goto L20;
}
/* L10: */
}
l = 1;
L20:
s_wsfe(&io___10);
do_fio(&c__1, line, l);
e_wsfe();
s_wsfe(&io___11);
e_wsfe();
/* Read in NM and the values for M. */
s_rsle(&io___12);
do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
e_rsle();
if (nm > 6) {
s_wsfe(&io___14);
do_fio(&c__1, "M", (ftnlen)1);
do_fio(&c__1, "NM", (ftnlen)2);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nm = 6;
}
s_rsle(&io___15);
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
s_wsfe(&io___18);
do_fio(&c__1, "M: ", (ftnlen)7);
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Check that M <= NMAXB for all values of M. */
mok = TRUE_;
maxm = 0;
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = mval[i__ - 1];
maxm = max(i__2,maxm);
if (mval[i__ - 1] > 5000) {
s_wsfe(&io___21);
do_fio(&c__1, "M", (ftnlen)1);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__5000, (ftnlen)sizeof(integer));
e_wsfe();
mok = FALSE_;
}
/* L30: */
}
if (! mok) {
s_wsle(&io___22);
e_wsle();
}
/* Read in NN and the values for N. */
s_rsle(&io___23);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn > 6) {
s_wsfe(&io___25);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, "NN", (ftnlen)2);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nn = 6;
}
s_rsle(&io___26);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
s_wsfe(&io___28);
do_fio(&c__1, "N: ", (ftnlen)7);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Check that N <= NMAXB for all values of N. */
nok = TRUE_;
maxn = 0;
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = nval[i__ - 1];
maxn = max(i__2,maxn);
if (nval[i__ - 1] > 5000) {
s_wsfe(&io___31);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__5000, (ftnlen)sizeof(integer));
e_wsfe();
nok = FALSE_;
}
/* L40: */
}
if (! nok) {
s_wsle(&io___32);
e_wsle();
}
/* Read in NK and the values for K. */
s_rsle(&io___33);
do_lio(&c__3, &c__1, (char *)&nk, (ftnlen)sizeof(integer));
e_rsle();
if (nk > 6) {
s_wsfe(&io___35);
do_fio(&c__1, "K", (ftnlen)1);
do_fio(&c__1, "NK", (ftnlen)2);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nk = 6;
}
s_rsle(&io___36);
i__1 = nk;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
s_wsfe(&io___38);
do_fio(&c__1, "K: ", (ftnlen)7);
i__1 = nk;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Find the maximum value of K (= NRHS). */
maxk = 0;
i__1 = nk;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = kval[i__ - 1];
maxk = max(i__2,maxk);
/* L50: */
}
mkmax = maxm * max(2,maxk);
/* Read in NNB and the values for NB. For the BLAS input files,
NBVAL is used to store values for INCX and INCY. */
s_rsle(&io___41);
do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
e_rsle();
if (nnb > 6) {
s_wsfe(&io___43);
do_fio(&c__1, "NB", (ftnlen)2);
do_fio(&c__1, "NNB", (ftnlen)3);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nnb = 6;
}
s_rsle(&io___44);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
/* Find the maximum value of NB. */
maxnb = 0;
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = nbval[i__ - 1];
maxnb = max(i__2,maxnb);
/* L60: */
}
if (blas) {
s_wsfe(&io___47);
do_fio(&c__1, "INCX: ", (ftnlen)7);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
nxval[i__ - 1] = 0;
/* L70: */
}
} else {
/* LAPACK data files: Read in the values for NX. */
s_rsle(&io___49);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
s_wsfe(&io___50);
do_fio(&c__1, "NB: ", (ftnlen)7);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_wsfe(&io___51);
do_fio(&c__1, "NX: ", (ftnlen)7);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read in NLDA and the values for LDA. */
s_rsle(&io___52);
do_lio(&c__3, &c__1, (char *)&nlda, (ftnlen)sizeof(integer));
e_rsle();
if (nlda > 4) {
s_wsfe(&io___54);
do_fio(&c__1, "LDA", (ftnlen)3);
do_fio(&c__1, "NLDA", (ftnlen)4);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
nlda = 4;
}
s_rsle(&io___55);
i__1 = nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer)
);
}
e_rsle();
s_wsfe(&io___57);
do_fio(&c__1, "LDA: ", (ftnlen)7);
i__1 = nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Check that LDA >= 1 for all values of LDA. */
ldaok = TRUE_;
maxlda = 0;
i__1 = nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = ldaval[i__ - 1];
maxlda = max(i__2,maxlda);
if (ldaval[i__ - 1] <= 0) {
s_wsfe(&io___60);
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
e_wsfe();
ldaok = FALSE_;
}
/* L80: */
}
if (! ldaok) {
s_wsle(&io___61);
e_wsle();
}
/* Check that MAXLDA*MAXN <= LA (for the dense routines). */
ldanok = TRUE_;
need = maxlda * maxn;
if (need > 272384) {
s_wsfe(&io___64);
do_fio(&c__1, (char *)&maxlda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&need, (ftnlen)sizeof(integer));
e_wsfe();
ldanok = FALSE_;
}
/* Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines). */
ldamok = TRUE_;
need = maxlda * maxm + maxm * maxk;
if (need > 817152) {
need = (need + 2) / 3;
s_wsfe(&io___66);
do_fio(&c__1, (char *)&maxlda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxm, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxk, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&need, (ftnlen)sizeof(integer));
e_wsfe();
ldamok = FALSE_;
}
/* Check that MAXN*MAXNB (or MAXN*INCX) <= LA. */
nxnbok = TRUE_;
need = maxn * maxnb;
if (need > 272384) {
s_wsfe(&io___68);
do_fio(&c__1, (char *)&maxn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxnb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&need, (ftnlen)sizeof(integer));
e_wsfe();
nxnbok = FALSE_;
}
if (! (mok && nok && ldaok && ldanok && nxnbok)) {
s_wsfe(&io___69);
e_wsfe();
goto L110;
}
if (! ldamok) {
s_wsle(&io___70);
e_wsle();
}
/* Read the minimum time to time a subroutine. */
s_wsle(&io___71);
e_wsle();
s_rsle(&io___72);
do_lio(&c__4, &c__1, (char *)&timmin, (ftnlen)sizeof(real));
e_rsle();
s_wsfe(&io___74);
do_fio(&c__1, (char *)&timmin, (ftnlen)sizeof(real));
e_wsfe();
s_wsle(&io___75);
e_wsle();
/* Read the first input line. */
i__1 = s_rsfe(&io___76);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
/* If the first record is the special signal 'NONE', then get the
next line but don't time SGEMV and SGEMM. */
if (lsamen_(&c__4, line, "NONE")) {
i__1 = s_rsfe(&io___77);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
} else {
s_wsfe(&io___78);
e_wsfe();
/* If the first record is the special signal 'BAND', then time
the band routine SGBMV and SGEMM with N = K. */
if (lsamen_(&c__4, line, "BAND")) {
if (ldamok) {
if (mkmax > 272384) {
i2 = 544768 - mkmax + 1;
j2 = 2;
} else {
i2 = 272384 - mkmax + 1;
j2 = 3;
}
i__1 = mkmax / 2;
stimmv_("SGBMV ", &nm, mval, &nn, nval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &i__1, &a_ref(i2, j2), &a_ref(
272384 - mkmax / 2 + 1, 3), reslts, &ldr1, &ldr2, &
c__6, (ftnlen)6);
} else {
s_wsfe(&io___83);
do_fio(&c__1, "SGBMV ", (ftnlen)6);
e_wsfe();
}
stimmm_("SGEMM ", "K", &nn, nval, &nlda, ldaval, &timmin, &a_ref(
1, 1), &a_ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &
c__6, (ftnlen)6, (ftnlen)1);
i__1 = s_rsfe(&io___84);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
} else {
/* Otherwise time SGEMV and SGEMM. */
stimmv_("SGEMV ", &nn, nval, &nnb, nbval, &nlda, ldaval, &timmin,
&a_ref(1, 1), &c_b172, &a_ref(1, 2), &a_ref(1, 3), reslts,
&ldr1, &ldr2, &c__6, (ftnlen)6);
stimmm_("SGEMM ", "N", &nn, nval, &nlda, ldaval, &timmin, &a_ref(
1, 1), &a_ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &
c__6, (ftnlen)6, (ftnlen)1);
}
}
/* Call the appropriate timing routine for each input line. */
s_wsfe(&io___85);
e_wsfe();
L90:
*(unsigned char *)c1 = *(unsigned char *)line;
s_copy(c2, line + 1, (ftnlen)2, (ftnlen)2);
s_copy(c3, line + 3, (ftnlen)3, (ftnlen)3);
/* Check first character for correct precision. */
if (! lsame_(c1, "Single precision")) {
s_wsfe(&io___89);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
} else if (lsamen_(&c__2, c2, "B2") || lsamen_(&
c__3, c3, "MV ") || lsamen_(&c__3, c3,
"SV ") || lsamen_(&c__3, c3, "R ") || lsamen_(&c__3, c3, "RC ")
|| lsamen_(&c__3, c3, "RU ") || lsamen_(&
c__3, c3, "R2 ")) {
/* Level 2 BLAS */
stimb2_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, &nlda,
ldaval, &c_b172, &timmin, &a_ref(1, 1), &a_ref(1, 2), &a_ref(
1, 3), reslts, &ldr1, &ldr2, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "B3") || lsamen_(&
c__3, c3, "MM ") || lsamen_(&c__3, c3,
"SM ") || lsamen_(&c__3, c3, "RK ") || lsamen_(&c__3, c3, "R2K"))
{
/* Level 3 BLAS */
stimb3_(line, &nm, mval, &nn, nval, &nk, kval, &nlda, ldaval, &timmin,
&a_ref(1, 1), &a_ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &
ldr2, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "QR") || lsamen_(&
c__2, c3, "QR") || lsamen_(&c__2, c3 + 1,
"QR")) {
/* QR routines */
stimqr_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "LQ") || lsamen_(&
c__2, c3, "LQ") || lsamen_(&c__2, c3 + 1,
"LQ")) {
/* LQ routines */
stimlq_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "QL") || lsamen_(&
c__2, c3, "QL") || lsamen_(&c__2, c3 + 1,
"QL")) {
/* QL routines */
stimql_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "RQ") || lsamen_(&
c__2, c3, "RQ") || lsamen_(&c__2, c3 + 1,
"RQ")) {
/* RQ routines */
stimrq_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "QP") || lsamen_(&
c__3, c3, "QPF")) {
/* QR with column pivoting */
stimqp_(line, &nm, mval, nval, &nlda, ldaval, &timmin, &a_ref(1, 1), &
a_ref(1, 2), &d___ref(1, 1), &a_ref(1, 3), iwork, reslts, &
ldr1, &ldr2, &c__6, (ftnlen)80);
/* Blas-3 QR with column pivoting */
stimq3_(line, &nm, mval, nval, &nnb, nbval, nxval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), &d___ref(1, 1), &a_ref(1,
3), iwork, reslts, &ldr1, &ldr2, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "HR") || lsamen_(&
c__3, c3, "HRD") || lsamen_(&c__2, c3 + 1,
"HR")) {
/* Reduction to Hessenberg form */
stimhr_(line, &nn, nval, &nk, kval, &nnb, nbval, nxval, &nlda, ldaval,
&timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3),
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TD") || lsamen_(&
c__3, c3, "TRD") || lsamen_(&c__2, c3 + 1,
"TR")) {
/* Reduction to tridiagonal form */
stimtd_(line, &nn, nval, &nk, kval, &nnb, nbval, nxval, &nlda, ldaval,
&timmin, &a_ref(1, 1), &a_ref(1, 2), &d___ref(1, 1), &
d___ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &ldr3, &
c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "BR") || lsamen_(&
c__3, c3, "BRD") || lsamen_(&c__2, c3 + 1,
"BR")) {
/* Reduction to bidiagonal form */
stimbr_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), &a_ref(1, 2), &d___ref(1, 1), &
d___ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &ldr3, &
c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "GE")) {
/* Routines for general matrices */
stimge_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), &a_ref(1, 3), iwork,
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General band matrices */
if (ldamok) {
stimgb_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, &nlda,
ldaval, &timmin, &a_ref(1, 1), &a_ref(272384 - mkmax + 1,
3), iwork, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)
80);
} else {
s_wsfe(&io___92);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "GT")) {
/* Routines for general tridiagonal matrices */
stimgt_(line, &nn, nval, &nk, kval, &nlda, ldaval, &timmin, &a_ref(1,
1), &a_ref(1, 2), iwork, reslts, &ldr1, &ldr2, &ldr3, &c__6, (
ftnlen)80);
} else if (lsamen_(&c__2, c2, "PO")) {
/* Positive definite matrices */
stimpo_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), iwork, reslts, &ldr1, &
ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "PP")) {
/* Positive definite packed matrices */
stimpp_(line, &nn, nval, &nk, kval, &c_b172, &timmin, &a_ref(1, 1), &
a_ref(1, 2), iwork, reslts, &ldr1, &ldr2, &ldr3, &c__6, (
ftnlen)80);
} else if (lsamen_(&c__2, c2, "PB")) {
/* Positive definite banded matrices */
if (ldamok) {
if (mkmax > 272384) {
j2 = 2;
i2 = 544768 - mkmax + 1;
} else {
j2 = 3;
i2 = 272384 - mkmax + 1;
}
stimpb_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, &nlda,
ldaval, &timmin, &a_ref(1, 1), &a_ref(i2, j2), iwork,
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else {
s_wsfe(&io___93);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PT")) {
/* Routines for positive definite tridiagonal matrices */
stimpt_(line, &nn, nval, &nk, kval, &nlda, ldaval, &timmin, &a_ref(1,
1), &a_ref(1, 2), reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)
80);
} else if (lsamen_(&c__2, c2, "SY")) {
/* Symmetric indefinite matrices */
stimsy_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), &a_ref(1, 3), iwork,
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "SP")) {
/* Symmetric indefinite packed matrices */
stimsp_(line, &nn, nval, &nk, kval, &c_b172, &timmin, &a_ref(1, 1), &
a_ref(1, 2), &a_ref(1, 3), iwork, reslts, &ldr1, &ldr2, &ldr3,
&c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrices */
stimtr_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), reslts, &ldr1, &ldr2, &
ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular packed matrices */
stimtp_(line, &nn, nval, &nk, kval, &c_b172, &timmin, &a_ref(1, 1), &
a_ref(1, 2), reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular band matrices */
if (ldamok) {
if (mkmax > 272384) {
j2 = 2;
i2 = 544768 - mkmax + 1;
} else {
j2 = 3;
i2 = 272384 - mkmax + 1;
}
stimtb_(line, &nm, mval, &nn, nval, &nk, kval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(i2, j2), reslts, &ldr1, &
ldr2, &ldr3, &c__6, (ftnlen)80);
} else {
s_wsfe(&io___94);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "LS")) {
/* Least squares drivers */
stimls_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, nxval, &
nlda, ldaval, &timmin, &a_ref(1, 1), &a_ref(1, 2), &b_ref(1,
1), &b_ref(1, 2), s, &s[512], opctbl, timtbl, flptbl, work,
iwork, &c__6, (ftnlen)80);
} else {
s_wsfe(&io___101);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
/* Read the next line of the input file. */
i__1 = s_rsfe(&io___102);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
goto L90;
/* Branch to this line when the last record is read. */
L100:
s2 = second_();
s_wsfe(&io___104);
e_wsfe();
s_wsfe(&io___105);
r__1 = s2 - s1;
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsfe();
L110:
/* End of STIMAA */
return 0;
} /* MAIN__ */
/* ------------------------------------------------------------------ */
/* Main program */ int MAIN__(void)
{
/* Format strings */
static char fmt_6000[] = "(3x,1p5e13.5)";
static char fmt_6110[] = "(1x,\002!!! WARNING: NEGATIVE \002,a,\002XS WA"
"S DETECTED IN GROUP\002,i3)";
static char fmt_6120[] = "(1x,\002!!! WARNING: NEGATIVE \002,a,\002XS WA"
"S DETECTED : \002,\002FROM GROUP \002,i3,\002 TO GROUP \002,i3)";
static char fmt_6130[] = "(1x,\002!!! WARNING: NEGATIVE SCATTERIG XS ("
"=\002,1pe12.5,\002) WAS SET TO ZERO.\002,/,\002 IT WAS ADDED"
" TO TOTAL(TRANSPORT) XS OF GROUP \002,i3)";
static char fmt_6200[] = "(1x,\002IGG=\002,i3,2x,1p220e12.5:/(10x,1p220e"
"12.5:))";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1;
static real equiv_0[1000000];
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void), s_rsle(cilist *), e_rsle(void),
s_cmp(char *, char *, ftnlen, ftnlen), s_wsue(cilist *), do_uio(
integer *, char *, ftnlen), e_wsue(void);
/* Local variables */
static integer i__, k, l, m, ig;
static real en[108];
static integer ng;
static real wt[108];
static integer igg, idm[50], irc;
static real scm[1144900] /* was [107][107][2][50] */;
static integer nin, ldw, lgv, npl, iht, lup, lss;
static real sum, xsm[32100] /* was [107][3][2][50] */;
static integer nds1, npl1, imac;
static char etag[1];
static integer leng, nbin, isgg;
static real scat[16692] /* was [107][156] */;
static char ptag[1*6*2];
static real xkai[5350] /* was [107][50] */;
static integer itbl, idum, nmat;
static real xsec[1070] /* was [107][10] */;
static integer note, lsct, iprn, itmp, ipos, iout;
#define work (equiv_0)
static integer nout1, nout2;
static real delay[4815] /* was [15][107][3] */;
static integer msave;
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer minsg, maxsg;
static char title[48];
static integer mcopt;
#define iwork ((integer *)equiv_0)
static integer mxdws, mxups;
extern /* Subroutine */ int macedt_(char *, integer *, integer *, char *,
integer *, real *, integer *, integer *, real *, real *, ftnlen,
ftnlen);
static integer idebug;
extern /* Subroutine */ int engedt_(char *, integer *, integer *, char *,
integer *, real *, real *, ftnlen, ftnlen);
static char member[8*50], dirnam[72], memnam[8];
extern /* Subroutine */ int uioset_(void);
/* Fortran I/O blocks */
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___16 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___20 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 0, 1, "(A72)", 0 };
static cilist io___31 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, 0, 0 };
static cilist io___36 = { 0, 0, 0, 0, 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___41 = { 0, 0, 0, 0, 0 };
static cilist io___42 = { 0, 0, 0, 0, 0 };
static cilist io___47 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___50 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___55 = { 0, 0, 1, "(A8,I10)", 0 };
static cilist io___57 = { 0, 0, 0, 0, 0 };
static cilist io___64 = { 0, 0, 0, 0, 0 };
static cilist io___70 = { 0, 0, 0, 0, 0 };
static cilist io___71 = { 0, 0, 0, 0, 0 };
static cilist io___72 = { 0, 0, 0, 0, 0 };
static cilist io___78 = { 0, 0, 0, 0, 0 };
static cilist io___79 = { 0, 0, 0, 0, 0 };
static cilist io___80 = { 0, 0, 0, 0, 0 };
static cilist io___81 = { 0, 0, 0, 0, 0 };
static cilist io___82 = { 0, 0, 0, 0, 0 };
static cilist io___83 = { 0, 0, 0, 0, 0 };
static cilist io___84 = { 0, 0, 0, 0, 0 };
static cilist io___85 = { 0, 0, 0, 0, 0 };
static cilist io___86 = { 0, 0, 0, 0, 0 };
static cilist io___87 = { 0, 0, 0, 0, 0 };
static cilist io___88 = { 0, 0, 0, 0, 0 };
static cilist io___89 = { 0, 0, 0, 0, 0 };
static cilist io___95 = { 0, 0, 0, 0, 0 };
static cilist io___96 = { 0, 0, 0, 0, 0 };
static cilist io___97 = { 0, 0, 0, 0, 0 };
static cilist io___98 = { 0, 0, 0, 0, 0 };
static cilist io___100 = { 0, 0, 0, 0, 0 };
static cilist io___101 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___102 = { 0, 0, 0, 0, 0 };
static cilist io___104 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___105 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___106 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___110 = { 0, 0, 0, fmt_6120, 0 };
static cilist io___111 = { 0, 0, 0, fmt_6130, 0 };
static cilist io___114 = { 0, 0, 0, fmt_6200, 0 };
static cilist io___116 = { 0, 0, 0, 0, 0 };
static cilist io___117 = { 0, 0, 0, 0, 0 };
static cilist io___118 = { 0, 0, 0, 0, 0 };
static cilist io___119 = { 0, 0, 0, 0, 0 };
static cilist io___120 = { 0, 0, 0, 0, 0 };
static cilist io___121 = { 0, 0, 0, 0, 0 };
/* ------------------------------------------------------------------ */
/* *********************************************************************** */
/* XSM(g,1,L,m) : absorption XS of m-th material (L-1 order) */
/* XSM(g,2,L,m) : production */
/* XSM(g,3,L,m) : total/transport */
/* SCM(g,g',L,m) : scattering matrix (g->g') of m-th material */
/* XKAI(g,m) : fission spectrum */
/* ----------------------------------------------------------------------- */
/* *********************************************************************** */
/* If you change I/O device number, */
/* Change subroutine (uiount) at the last. */
nin = 5;
nout1 = 6;
nout2 = 99;
nbin = 1;
iout = nout1;
iprn = 1;
note = 0;
uioset_();
/* *********************************************************************** */
/* LOGO PRINT (99) */
/* *********************************************************************** */
io___10.ciunit = nout1;
s_wsle(&io___10);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___11.ciunit = nout1;
s_wsle(&io___11);
do_lio(&c__9, &c__1, " SRAC UTILITY TO CONVERT MACROSCOPIC XS DATA", (
ftnlen)44);
e_wsle();
io___12.ciunit = nout1;
s_wsle(&io___12);
do_lio(&c__9, &c__1, " OF PDS TO ANISN TYPE BINARY LIBRARY DATA", (ftnlen)
41);
e_wsle();
io___13.ciunit = nout1;
s_wsle(&io___13);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___14.ciunit = nout2;
s_wsle(&io___14);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___15.ciunit = nout2;
s_wsle(&io___15);
do_lio(&c__9, &c__1, " SRAC UTILITY TO CONVERT MACROSCOPIC XS DATA", (
ftnlen)44);
e_wsle();
io___16.ciunit = nout2;
s_wsle(&io___16);
do_lio(&c__9, &c__1, " OF PDS TO ANISN TYPE BINARY LIBRARY DATA", (ftnlen)
41);
e_wsle();
io___17.ciunit = nout2;
s_wsle(&io___17);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___18.ciunit = nout2;
s_wsle(&io___18);
do_lio(&c__9, &c__1, " THE BINARY DATA IS AVAILABLE IN ANISN, TWOTRAN", (
ftnlen)47);
do_lio(&c__9, &c__1, " GMVP, MORSE, ETC.", (ftnlen)18);
e_wsle();
io___19.ciunit = nout2;
s_wsle(&io___19);
do_lio(&c__9, &c__1, " NOTE: ANISN FORMAT DOSE NOT INCLUDE MATERIAL-", (
ftnlen)46);
do_lio(&c__9, &c__1, " DEPENDENT FISSION SPECTRA.", (ftnlen)27);
e_wsle();
io___20.ciunit = nout2;
s_wsle(&io___20);
do_lio(&c__9, &c__1, " USE THE PRINTED FISSION SPECTRA IF NECESSARY.", (
ftnlen)46);
e_wsle();
io___21.ciunit = nout2;
s_wsle(&io___21);
e_wsle();
/* *********************************************************************** */
/* SET PL-TAG OF SRAC MEMBERS IN MACRO(1) OR MACROWRK(2) */
/* (SET INITIAL CHARACTER DATA) */
/* *********************************************************************** */
s_copy(title, " ", (ftnlen)
48, (ftnlen)48);
*(unsigned char *)&ptag[0] = '0';
*(unsigned char *)&ptag[1] = '1';
*(unsigned char *)&ptag[2] = 'X';
*(unsigned char *)&ptag[3] = 'X';
*(unsigned char *)&ptag[4] = 'X';
*(unsigned char *)&ptag[5] = 'X';
*(unsigned char *)&ptag[6] = '4';
*(unsigned char *)&ptag[7] = '3';
*(unsigned char *)&ptag[8] = '5';
*(unsigned char *)&ptag[9] = '6';
*(unsigned char *)&ptag[10] = '7';
*(unsigned char *)&ptag[11] = '8';
/* *********************************************************************** */
/* READ DIRECTORY NAME OF MACRO/MACROWRK */
/* Check MACRO or MACROWRK */
/* READ ENERGY GROUP STRUCTURE FROM CONTA00[0,2] */
/* *********************************************************************** */
/* IMAC=1 : MACRO */
/* =2 : MACROWRK */
io___24.ciunit = nin;
i__1 = s_rsfe(&io___24);
if (i__1 != 0) {
goto L9999;
}
i__1 = do_fio(&c__1, dirnam, (ftnlen)72);
if (i__1 != 0) {
goto L9999;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L9999;
}
s_copy(memnam, "CONTA000", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 1;
*(unsigned char *)etag = 'A';
goto L100;
}
s_copy(memnam, "CONTA002", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 2;
*(unsigned char *)etag = 'A';
goto L100;
}
s_copy(memnam, "CONTF000", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 1;
*(unsigned char *)etag = 'F';
goto L100;
}
s_copy(memnam, "CONTF002", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 2;
*(unsigned char *)etag = 'F';
goto L100;
}
io___31.ciunit = nout1;
s_wsle(&io___31);
do_lio(&c__9, &c__1, " ERROR : PDSIN FAILED, IRC=", (ftnlen)27);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_stop("999", (ftnlen)3);
L100:
engedt_(dirnam, &iout, &iprn, memnam, &ng, wt, en, (ftnlen)72, (ftnlen)8);
io___35.ciunit = nout2;
s_wsle(&io___35);
do_lio(&c__9, &c__1, " NUMBER OF ENERGY GROUPS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&ng, (ftnlen)sizeof(integer));
e_wsle();
io___36.ciunit = nout2;
s_wsle(&io___36);
e_wsle();
io___37.ciunit = nout2;
s_wsle(&io___37);
do_lio(&c__9, &c__1, " << ENERGY BOUNDARY OF MACROSCOPIC XS >>", (ftnlen)
40);
e_wsle();
io___38.ciunit = nout2;
s_wsle(&io___38);
e_wsle();
io___39.ciunit = nout2;
s_wsfe(&io___39);
i__1 = ng + 1;
for (ig = 1; ig <= i__1; ++ig) {
do_fio(&c__1, (char *)&en[ig - 1], (ftnlen)sizeof(real));
}
e_wsfe();
io___41.ciunit = nout2;
s_wsle(&io___41);
e_wsle();
/* *********************************************************************** */
/* READ PL ORDER AND Monte Carlo Option */
/* MCOPT = 0 : accept negative XS (caused by transport correction) */
/* = 1 : not accept negative scattering XS */
/* SIGT = SIGT + ABS(SIGS) and SIGS=0 */
/* MSAVE = 0 : down-scattering size is forced to be NG-1 (suggested) */
/* = 1 : down-scattering size is searched (additional input NDS1 */
/* is necessary in GMVP (output library may be not available */
/* in some codes (ex. MORSE) */
/* *********************************************************************** */
io___42.ciunit = nin;
s_rsle(&io___42);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&mcopt, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&idebug, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&msave, (ftnlen)sizeof(integer));
e_rsle();
io___47.ciunit = nout2;
s_wsle(&io___47);
do_lio(&c__9, &c__1, " INPUT PL ORDER (NPL) = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
e_wsle();
io___48.ciunit = nout2;
s_wsle(&io___48);
do_lio(&c__9, &c__1, " OPTION FOR NEGATIVE XS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mcopt, (ftnlen)sizeof(integer));
e_wsle();
io___49.ciunit = nout2;
s_wsle(&io___49);
do_lio(&c__9, &c__1, " OPTION FOR DEBUG PRINT = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&idebug, (ftnlen)sizeof(integer));
e_wsle();
io___50.ciunit = nout2;
s_wsle(&io___50);
do_lio(&c__9, &c__1, " OPTION FOR MEMORY SAVVING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&msave, (ftnlen)sizeof(integer));
e_wsle();
if (npl < 0) {
io___51.ciunit = nout1;
s_wsle(&io___51);
do_lio(&c__9, &c__1, " ERROR: INPUT PL-OREDER(=", (ftnlen)25);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS INVALID", (ftnlen)12);
e_wsle();
}
if (mcopt != 0) {
mcopt = 1;
}
if (npl > 1) {
io___52.ciunit = nout1;
s_wsle(&io___52);
do_lio(&c__9, &c__1, " ERROR: INPUT PL-OREDER IS GREATER THAN", (
ftnlen)39);
do_lio(&c__9, &c__1, " PROGRAM ARRAY SIZE (=", (ftnlen)22);
do_lio(&c__3, &c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
s_stop("777", (ftnlen)3);
}
if (npl == 0 && imac == 2) {
*(unsigned char *)&ptag[6] = '2';
}
npl1 = npl + 1;
/* *********************************************************************** */
/* READ MEMBERS (MATERIALS) */
/* *********************************************************************** */
nmat = 0;
L200:
io___55.ciunit = nin;
i__1 = s_rsfe(&io___55);
if (i__1 != 0) {
goto L210;
}
i__1 = do_fio(&c__1, memnam, (ftnlen)8);
if (i__1 != 0) {
goto L210;
}
i__1 = do_fio(&c__1, (char *)&idum, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L210;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L210;
}
if (s_cmp(memnam, " ", (ftnlen)8, (ftnlen)8) == 0) {
goto L210;
}
++nmat;
if (nmat > 50) {
io___57.ciunit = nout1;
s_wsle(&io___57);
do_lio(&c__9, &c__1, " ERROR: NUMBER OF INPUT MEMBERS IS ", (ftnlen)
35);
do_lio(&c__9, &c__1, " GREATER THAN PROGRAM ARRAY SIZE (=", (ftnlen)
35);
do_lio(&c__3, &c__1, (char *)&c__50, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
s_stop("777", (ftnlen)3);
}
s_copy(member + (nmat - 1 << 3), memnam, (ftnlen)8, (ftnlen)8);
idm[nmat - 1] = idum;
goto L200;
L210:
/* *********************************************************************** */
/* SEARCH MAX UP-SCATTERING AND MAX DOWN-SCATTERIG SIZES */
/* AMONG MEMBERS */
/* *********************************************************************** */
mxups = 0;
mxdws = 0;
i__1 = nmat;
for (m = 1; m <= i__1; ++m) {
i__2 = npl1;
for (l = 1; l <= i__2; ++l) {
s_copy(memnam, member + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
*(unsigned char *)&memnam[4] = *(unsigned char *)etag;
*(unsigned char *)&memnam[7] = *(unsigned char *)&ptag[l + imac *
6 - 7];
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (
ftnlen)8);
if (irc != 0) {
io___64.ciunit = nout1;
s_wsle(&io___64);
do_lio(&c__9, &c__1, " ERROR : PDSIN FAILED, IRC=", (ftnlen)
27);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_stop("999", (ftnlen)3);
}
ipos = 0;
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
lss = iwork[ipos];
lgv = iwork[ipos + 1];
lup = lss - 1;
ldw = lgv - lss;
mxups = max(lup,mxups);
mxdws = max(ldw,mxdws);
ipos = ipos + 10 + lgv;
/* L320: */
}
/* L310: */
}
/* L300: */
}
if (msave == 0) {
io___70.ciunit = nout2;
s_wsle(&io___70);
do_lio(&c__9, &c__1, " REAL MAX. SIZE OF DOWN-SCATTERING (", (ftnlen)
36);
do_lio(&c__3, &c__1, (char *)&mxdws, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") WAS REPLACED BY ", (ftnlen)18);
i__1 = ng - 1;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
mxdws = ng - 1;
}
io___71.ciunit = nout2;
s_wsle(&io___71);
do_lio(&c__9, &c__1, " MAX. SIZE OF UP-SCATTERING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mxups, (ftnlen)sizeof(integer));
e_wsle();
io___72.ciunit = nout2;
s_wsle(&io___72);
do_lio(&c__9, &c__1, " MAX. SIZE OF DOWN-SCATTERING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mxdws, (ftnlen)sizeof(integer));
e_wsle();
/* *********************************************************************** */
/* READ MEMBER XS AND SET IT IN ANISN FORMAT */
/* *********************************************************************** */
/* IHT : position of total cross section in a group XS data */
/* ISGG: position of self-scattering in a group XS data */
/* ITBL: length of a group XS data */
/* LSCT: length of a scattering data in a group */
/* LENG: record length of all group XS data */
/* NDS1: size of down-scattering + 1(self-scattering) */
iht = 3;
isgg = iht + mxups + 1;
itbl = isgg + mxdws;
lsct = mxups + 1 + mxdws;
leng = ng * itbl;
nds1 = mxdws + 1;
io___78.ciunit = nout2;
s_wsle(&io___78);
do_lio(&c__9, &c__1, " SIZE OF SCATTERING VECTOR = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&lsct, (ftnlen)sizeof(integer));
e_wsle();
io___79.ciunit = nout2;
s_wsle(&io___79);
do_lio(&c__9, &c__1, " IHT : POSITION OF TOTAL XS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&iht, (ftnlen)sizeof(integer));
e_wsle();
io___80.ciunit = nout2;
s_wsle(&io___80);
do_lio(&c__9, &c__1, " ISGG: POSITION OF SELF-SCATTERNG = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&isgg, (ftnlen)sizeof(integer));
e_wsle();
io___81.ciunit = nout2;
s_wsle(&io___81);
do_lio(&c__9, &c__1, " ITBL: LENGTH OF A GROUP XS DATA = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&itbl, (ftnlen)sizeof(integer));
e_wsle();
io___82.ciunit = nout2;
s_wsle(&io___82);
do_lio(&c__9, &c__1, " NDS1: LENGTH OF DOWN+SELF SCAT. = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&nds1, (ftnlen)sizeof(integer));
e_wsle();
/* ----- MACEDT ARRANGEMENT ------------------------------ */
/* XSEX(g,1): production */
/* XSEX(g,2): fission */
/* XSEX(g,3): capture defined as (absorption - fission) */
/* XSEX(g,4): absorption */
/* XSEX(g,5): fission spectrum */
/* XSEX(g,6): diffusion coefficient (D1) */
/* XSEX(g,7): diffusion coefficient (D2) */
/* XSEX(g,8): total or transport */
/* XSEX(g,9): velocity cross section */
/* SCAT(g,g'): full size of scattering matrix (g=>g') */
/* ----- FOR ANISN FORMAT */
/* XSM(g,1,L,m) : absorption XS of m-th material (L-1 order) */
/* XSM(g,2,L,m) : production */
/* XSM(g,3,L,m) : total/transport */
/* SCM(g,g',L,m) : scattering matrix (g->g') of m-th material */
/* ----- Sample when NG=9 -------------------------------------- */
/* 1 2 IHT, [MXUPS] ISGG [MXDWS] ITBL */
/* g=1 Ag, Pg, Tg, 0 .....3->1 2->1 1->1 0 0 0 ....... 0 */
/* g=2 Ag, Pg, Tg, 0 0 ...4->2 3->2 2->2 1->2 ....... 0 */
/* g=3 Ag, Pg, Tg, 0 0 0 0 ....4->3 3->3 2->3 1->3 .. 0 */
/* : : : : : : : : : : */
/* : : : : : : : : : : */
/* g=9 Ag, Pg, Tg, 0 0 0 0 ......0 9->9 8->9 7->9 .... */
/* ------------------------------------------------------------- */
io___83.ciunit = nout2;
s_wsle(&io___83);
e_wsle();
i__1 = nmat;
for (m = 1; m <= i__1; ++m) {
io___84.ciunit = nout2;
s_wsle(&io___84);
e_wsle();
io___85.ciunit = nout2;
s_wsle(&io___85);
do_lio(&c__9, &c__1, " ******************************", (ftnlen)31);
e_wsle();
io___86.ciunit = nout2;
s_wsle(&io___86);
do_lio(&c__9, &c__1, " INPUT MEMBER NAME = ", (ftnlen)22);
do_lio(&c__9, &c__1, member + (m - 1 << 3), (ftnlen)8);
e_wsle();
io___87.ciunit = nout2;
s_wsle(&io___87);
do_lio(&c__9, &c__1, " INPUT MATERIAL ID = ", (ftnlen)22);
do_lio(&c__3, &c__1, (char *)&idm[m - 1], (ftnlen)sizeof(integer));
e_wsle();
io___88.ciunit = nout2;
s_wsle(&io___88);
do_lio(&c__9, &c__1, " ******************************", (ftnlen)31);
e_wsle();
io___89.ciunit = nout2;
s_wsle(&io___89);
e_wsle();
i__2 = npl1;
for (l = 1; l <= i__2; ++l) {
s_copy(memnam, member + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
*(unsigned char *)&memnam[4] = *(unsigned char *)etag;
*(unsigned char *)&memnam[7] = *(unsigned char *)&ptag[l + imac *
6 - 7];
macedt_(dirnam, &iout, &iprn, memnam, &ng, xsec, &minsg, &maxsg,
scat, delay, (ftnlen)72, (ftnlen)8);
if (idebug == 1) {
io___95.ciunit = nout2;
s_wsle(&io___95);
e_wsle();
io___96.ciunit = nout2;
s_wsle(&io___96);
do_lio(&c__9, &c__1, " << MEMBER NAME OF THE PL(=", (ftnlen)
27);
i__3 = l - 1;
do_lio(&c__3, &c__1, (char *)&i__3, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") COMPONENT : ", (ftnlen)14);
do_lio(&c__9, &c__1, memnam, (ftnlen)8);
do_lio(&c__9, &c__1, " >>", (ftnlen)3);
e_wsle();
io___97.ciunit = nout2;
s_wsle(&io___97);
e_wsle();
}
s_copy(title, memnam, (ftnlen)8, (ftnlen)8);
io___98.ciunit = nbin;
s_wsue(&io___98);
do_uio(&c__1, (char *)&ng, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&itbl, (ftnlen)sizeof(integer));
i__3 = l - 1;
do_uio(&c__1, (char *)&i__3, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&idm[m - 1], (ftnlen)sizeof(integer));
do_uio(&c__1, title, (ftnlen)48);
e_wsue();
if (l == 1) {
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
xkai[ig + m * 107 - 108] = xsec[ig + 427];
/* L400: */
}
io___100.ciunit = nout2;
s_wsle(&io___100);
do_lio(&c__9, &c__1, " << MATERIAL DEPENDENT FISSION SPECTRU"
"M >>", (ftnlen)42);
e_wsle();
io___101.ciunit = nout2;
s_wsfe(&io___101);
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
do_fio(&c__1, (char *)&xkai[ig + m * 107 - 108], (ftnlen)
sizeof(real));
}
e_wsfe();
io___102.ciunit = nout2;
s_wsle(&io___102);
e_wsle();
}
/* *********************************************************************** */
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
xsm[ig + ((l + (m << 1)) * 3 + 1) * 107 - 1071] = xsec[ig +
320];
xsm[ig + ((l + (m << 1)) * 3 + 2) * 107 - 1071] = xsec[ig - 1]
;
xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] = xsec[ig +
748];
/* -----------Check Negative XS */
if (l == 1) {
if (xsm[ig + ((l + (m << 1)) * 3 + 1) * 107 - 1071] < 0.f)
{
io___104.ciunit = nout2;
s_wsfe(&io___104);
do_fio(&c__1, "ABSORPTION", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
if (xsm[ig + ((l + (m << 1)) * 3 + 2) * 107 - 1071] < 0.f)
{
io___105.ciunit = nout2;
s_wsfe(&io___105);
do_fio(&c__1, "PRODUCTION", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
if (xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] < 0.f)
{
io___106.ciunit = nout2;
s_wsfe(&io___106);
do_fio(&c__1, "TOTAL(TRA)", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
}
sum = 0.f;
i__4 = ng;
for (igg = 1; igg <= i__4; ++igg) {
scm[ig + (igg + (l + (m << 1)) * 107) * 107 - 34455] =
scat[ig + igg * 107 + 5135];
/* -----------Check Negative Scattering XS */
if (l == 1) {
if (scm[ig + (igg + (l + (m << 1)) * 107) * 107 -
34455] < 0.f) {
io___110.ciunit = nout2;
s_wsfe(&io___110);
do_fio(&c__1, "SCATTERING", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&igg, (ftnlen)sizeof(
integer));
e_wsfe();
++note;
if (mcopt != 0) {
sum += (r__1 = scm[ig + (igg + (l + (m << 1))
* 107) * 107 - 34455], dabs(r__1));
scm[ig + (igg + (l + (m << 1)) * 107) * 107 -
34455] = 0.f;
}
}
}
/* L420: */
}
if (l == 1 && sum != 0.f) {
xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] += sum;
io___111.ciunit = nout2;
s_wsfe(&io___111);
do_fio(&c__1, (char *)&sum, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
/* L410: */
}
/* --------- set one group XS data(one record) in WORK dimension */
/* (Note : loop on sink group) */
ipos = 0;
i__3 = ng;
for (igg = 1; igg <= i__3; ++igg) {
work[ipos] = xsm[igg + ((l + (m << 1)) * 3 + 1) * 107 - 1071];
work[ipos + 1] = xsm[igg + ((l + (m << 1)) * 3 + 2) * 107 -
1071];
work[ipos + 2] = xsm[igg + ((l + (m << 1)) * 3 + 3) * 107 -
1071];
ipos += 3;
/* -----------SET SCATTERIG XS (LSCT=MXUPS+1+MXDWS) */
i__4 = lsct;
for (k = 1; k <= i__4; ++k) {
ig = igg + mxups + 1 - k;
if (ig <= ng && ig >= 1) {
work[ipos + k - 1] = scm[ig + (igg + (l + (m << 1)) *
107) * 107 - 34455];
} else {
work[ipos + k - 1] = 0.f;
}
/* L440: */
}
ipos += lsct;
if (idebug == 1) {
itmp = ipos - (lsct + 3) + 1;
io___114.ciunit = nout2;
s_wsfe(&io___114);
do_fio(&c__1, (char *)&igg, (ftnlen)sizeof(integer));
i__4 = ipos;
for (i__ = itmp; i__ <= i__4; ++i__) {
do_fio(&c__1, (char *)&work[i__ - 1], (ftnlen)sizeof(
real));
}
e_wsfe();
}
/* L430: */
}
io___116.ciunit = nbin;
s_wsue(&io___116);
i__3 = ipos;
for (i__ = 1; i__ <= i__3; ++i__) {
do_uio(&c__1, (char *)&work[i__ - 1], (ftnlen)sizeof(real));
}
e_wsue();
/* L1100: */
}
/* L1000: */
}
if (note != 0) {
io___117.ciunit = nout2;
s_wsle(&io___117);
e_wsle();
io___118.ciunit = nout2;
s_wsle(&io___118);
do_lio(&c__9, &c__1, " THERE ARE ", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)¬e, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " WARNING MESSAGES MARKED ", (ftnlen)25);
do_lio(&c__9, &c__1, "BY (!!! WARNING:) ", (ftnlen)18);
e_wsle();
io___119.ciunit = nout2;
s_wsle(&io___119);
e_wsle();
}
io___120.ciunit = nout2;
s_wsle(&io___120);
e_wsle();
io___121.ciunit = nout2;
s_wsle(&io___121);
do_lio(&c__9, &c__1, " ================ NORMAL END ===================", (
ftnlen)48);
e_wsle();
/* *********************************************************************** */
L9999:
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int neclumpn_(real *x, real *y, real *z__, real *necn, real *
fcn, integer *hitclump)
{
/* Initialized data */
static logical first = TRUE_;
static integer luclump = 11;
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer f_open(olist *), s_rsle(cilist *), e_rsle(void), do_lio(integer *,
integer *, char *, ftnlen);
double sin(doublereal), cos(doublereal);
integer f_clos(cllist *);
double exp(doublereal);
/* Local variables */
static integer j, clumpflag;
static real bc[2000], dc[2000], fc[2000], lc[2000], rc[2000], xc[2000],
yc[2000], zc[2000], cbc, clc, nec[2000], sbc, arg, slc;
static integer edge[2000];
static real rgalc;
/* Fortran I/O blocks */
static cilist io___4 = { 0, 0, 0, 0, 0 };
static cilist io___5 = { 0, 0, 1, 0, 0 };
/* returns electron density necN and fluctuation parameter FcN */
/* at position designated by l,b,d,x,y,z c for a set of */
/* clumps with parameters read in from file neclumpN.dat */
/* input: */
/* x,y,z coordinates (kpc) (as in TC93) */
/* output: */
/* necN electron density in clump at (x,y,z) */
/* FcN fluctuation parameter */
/* hitclump = 0: no clump hit */
/* j>0: j-th clump hit */
/* character*15 losname(nclumpsmax) */
/* character*1 type(nclumpsmax) */
/* parameters: */
/* lc = galactic longitude of clump center */
/* bc = galactic latitude of clump center */
/* (xc,yc,zc) = clump center location (calculated) */
/* nec = internal peak electron density */
/* rc = clump radius at 1/e */
/* Fc = clump fluctuation parameter */
/* edge = 0 => use exponential rolloff out to 5rc */
/* 1 => uniform and truncated at 1/e */
/* data first/.true./ */
/* data luclump/11/ */
/* first time through, read input clump parameters and calculate */
/* LOS quantities. */
/* lc,bc = Galactic coordinates (deg) */
/* nec = clump electron density (cm^{-3}) */
/* Fc = fluctuation parameter */
/* dc = clump distance from Earth (kpc) */
/* rc = clump radius (kpc) */
/* edge = 0,1 0=> Gaussian, 1=> Gaussian w/ hard edge at e^{-1} */
/* type = LOS type (P pulsar, G other Galactic, X extragalactic */
/* losname = useful name */
if (first) {
/* read clump parameters */
j = 1;
/* write(6,*) 'reading neclumpN.NE2001.dat' */
o__1.oerr = 0;
o__1.ounit = luclump;
o__1.ofnmlen = 19;
o__1.ofnm = "neclumpN.NE2001.dat";
o__1.orl = 0;
o__1.osta = "old";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
io___4.ciunit = luclump;
s_rsle(&io___4);
e_rsle();
/* label line */
L5:
io___5.ciunit = luclump;
i__1 = s_rsle(&io___5);
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__3, &c__1, (char *)&clumpflag, (ftnlen)sizeof(
integer));
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__4, &c__1, (char *)&lc[j - 1], (ftnlen)sizeof(real));
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__4, &c__1, (char *)&bc[j - 1], (ftnlen)sizeof(real));
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__4, &c__1, (char *)&nec[j - 1], (ftnlen)sizeof(real))
;
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__4, &c__1, (char *)&fc[j - 1], (ftnlen)sizeof(real));
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__4, &c__1, (char *)&dc[j - 1], (ftnlen)sizeof(real));
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__4, &c__1, (char *)&rc[j - 1], (ftnlen)sizeof(real));
if (i__1 != 0) {
goto L99;
}
i__1 = do_lio(&c__3, &c__1, (char *)&edge[j - 1], (ftnlen)sizeof(
integer));
if (i__1 != 0) {
goto L99;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L99;
}
if (clumpflag == 0) {
slc = sin(lc[j - 1] / 57.29577951f);
clc = cos(lc[j - 1] / 57.29577951f);
sbc = sin(bc[j - 1] / 57.29577951f);
cbc = cos(bc[j - 1] / 57.29577951f);
rgalc = dc[j - 1] * cbc;
xc[j - 1] = rgalc * slc;
yc[j - 1] = 8.5f - rgalc * clc;
zc[j - 1] = dc[j - 1] * sbc;
/* write(6,"(a15,1x,8(f8.3,1x))") */
/* . losname(j),lc(j),bc(j),dc(j), */
/* . nec(j),Fc(j),xc(j),yc(j),zc(j) */
++j;
}
goto L5;
L99:
first = FALSE_;
clumps_1.nclumps = j - 1;
cl__1.cerr = 0;
cl__1.cunit = luclump;
cl__1.csta = 0;
f_clos(&cl__1);
}
*necn = 0.f;
*hitclump = 0;
*fcn = 0.f;
i__1 = clumps_1.nclumps;
for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
r__1 = *x - xc[j - 1];
/* Computing 2nd power */
r__2 = *y - yc[j - 1];
/* Computing 2nd power */
r__3 = *z__ - zc[j - 1];
/* Computing 2nd power */
r__4 = rc[j - 1];
arg = (r__1 * r__1 + r__2 * r__2 + r__3 * r__3) / (r__4 * r__4);
if (edge[j - 1] == 0 && arg < 5.f) {
*necn += nec[j - 1] * exp(-arg);
*fcn = fc[j - 1];
*hitclump = j;
clumps_1.hitclumpflag[j - 1] = 1;
}
if (edge[j - 1] == 1 && arg <= 1.f) {
/* necN = necN + nec(j) * exp(-arg) */
*necn += nec[j - 1];
*fcn = fc[j - 1];
*hitclump = j;
clumps_1.hitclumpflag[j - 1] = 1;
}
}
return 0;
} /* neclumpn_ */
/* Subroutine */ int cdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, complex *a, integer *lda, complex *h__, complex *ht,
complex *w, complex *wt, complex *wtmp, complex *vs, integer *ldvs,
complex *vs1, real *result, complex *work, integer *lwork, real *
rwork, logical *bwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9991[] = "(\002 CDRVSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Complex Schur Form Decompositi"
"on Expert \002,\002Driver\002,/\002 Matrix types (see CDRVSX for"
" details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
"\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
" otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
"p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
" (no sort) \002,/\002 4 = 0 if W are eigenvalues of T (no sort)"
",\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T same no matter "
"if VS computed (no sort),\002,\002 1/ulp otherwise\002,/\002 6 "
"= 0 if W same no matter if VS computed (no sort)\002,\002, 1/ul"
"p otherwise\002)";
static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
"/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
"( n ulp ) (sort) \002,/\002 10 = 0 if W are eigenvalues of T (so"
"rt),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if T same no mat"
"ter what else computed (sort),\002,\002 1/ulp otherwise\002,"
"/\002 12 = 0 if W same no matter what else computed \002,\002(so"
"rt), 1/ulp otherwise\002,/\002 13 = 0 if sorting succesful, 1/ul"
"p otherwise\002,/\002 14 = 0 if RCONDE same no matter what else "
"computed,\002,\002 1/ulp otherwise\002,/\002 15 = 0 if RCONDv sa"
"me no matter what else computed,\002,\002 1/ulp otherwise\002,"
"/\002 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002,/"
"\002 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, n, iwk;
real ulp, cond;
integer jcol;
char path[3];
integer nmax;
real unfl, ovfl;
integer isrt;
logical badnn;
extern /* Subroutine */ int cget24_(logical *, integer *, real *, integer
*, integer *, integer *, complex *, integer *, complex *, complex
*, complex *, complex *, complex *, complex *, integer *, complex
*, real *, real *, integer *, integer *, integer *, real *,
complex *, integer *, real *, logical *, integer *);
integer nfail, imode, iinfo;
real conds, anorm;
integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
real rtulp;
extern /* Subroutine */ int slabad_(real *, real *);
real rcdein;
extern /* Subroutine */ int clatme_(integer *, char *, integer *, complex
*, integer *, real *, complex *, char *, char *, char *, char *,
real *, integer *, real *, integer *, integer *, real *, complex *
, integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
integer idumma[1], ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
integer *, integer *, char *, integer *, char *, complex *,
integer *, real *, complex *, char *, char *, complex *, integer *
, real *, complex *, integer *, real *, char *, integer *,
integer *, integer *, real *, real *, char *, complex *, integer *
, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
real *, integer *, real *, real *, integer *, integer *, char *,
complex *, integer *, complex *, integer *);
real rcdvin;
integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*);
real ulpinv;
integer nnwork;
real rtulpi;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___31 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___47 = { 0, 0, 1, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
/* expert driver CGEESX. */
/* CDRVSX uses both test matrices generated randomly depending on */
/* data supplied in the calling sequence, as well as on data */
/* read from an input file and including precomputed condition */
/* numbers to which it compares the ones it computes. */
/* When CDRVSX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
/* tests will be performed: */
/* (1) 0 if T is in Schur form, 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (2) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (no sorting of eigenvalues). */
/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
/* (4) 0 if W are eigenvalues of T */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (5) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (7) 0 if T is in Schur form, 1/ulp otherwise */
/* (with sorting of eigenvalues) */
/* (8) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (with sorting of eigenvalues). */
/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) 0 if W are eigenvalues of T */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare W with and */
/* without reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (11) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare T with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare VS with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (13) if sorting worked and SDIM is the number of */
/* eigenvalues which were SELECTed */
/* If workspace sufficient, also compare SDIM with and */
/* without reciprocal condition numbers */
/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is orthogonal and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalue */
/* average and right invariant subspace. For these matrices, in */
/* addition to tests (1) to (15) we will compute the following two */
/* tests: */
/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal average eigenvalue condition number */
/* computed by CGEESX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right invariant subspace condition */
/* number computed by CGEESX and RCDVIN (the precomputed true */
/* value) is supplied as input. cond(RCONDV) is the condition */
/* number of RCONDV, and takes errors in computing RCONDV into */
/* account, so that the resulting quantity should be O(ULP). */
/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
/* additional type, MAXTYP+1 is defined, which is to use */
/* whatever matrix is in A. This is only useful if */
/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to CDRVSX to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIUNIT (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) COMPLEX array, dimension (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max( NN ). */
/* H (workspace) COMPLEX array, dimension (LDA, max(NN)) */
/* Another copy of the test matrix A, modified by CGEESX. */
/* HT (workspace) COMPLEX array, dimension (LDA, max(NN)) */
/* Yet another copy of the test matrix A, modified by CGEESX. */
/* W (workspace) COMPLEX array, dimension (max(NN)) */
/* The computed eigenvalues of A. */
/* WT (workspace) COMPLEX array, dimension (max(NN)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when CGEESX only computes a partial */
/* eigendecomposition, i.e. not Schur vectors */
/* WTMP (workspace) COMPLEX array, dimension (max(NN)) */
/* More temporary storage for eigenvalues. */
/* VS (workspace) COMPLEX array, dimension (LDVS, max(NN)) */
/* VS holds the computed Schur vectors. */
/* LDVS (input) INTEGER */
/* Leading dimension of VS. Must be at least max(1,max(NN)). */
/* VS1 (workspace) COMPLEX array, dimension (LDVS, max(NN)) */
/* VS1 holds another copy of the computed Schur vectors. */
/* RESULT (output) REAL array, dimension (17) */
/* The values computed by the 17 tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(1,2*NN(j)**2) for all j. */
/* RWORK (workspace) REAL array, dimension (max(NN)) */
/* BWORK (workspace) LOGICAL array, dimension (max(NN)) */
/* INFO (output) INTEGER */
/* If 0, successful exit. */
/* <0, input parameter -INFO is incorrect */
/* >0, CLATMR, CLATMS, CLATME or CGET24 returned an error */
/* code and INFO is its absolute value */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
ht_dim1 = *lda;
ht_offset = 1 + ht_dim1;
ht -= ht_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--wt;
--wtmp;
vs1_dim1 = *ldvs;
vs1_offset = 1 + vs1_dim1;
vs1 -= vs1_offset;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--result;
--work;
--rwork;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 8 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 8;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*niunit <= 0) {
*info = -7;
} else if (*nounit <= 0) {
*info = -8;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvs < 1 || *ldvs < nmax) {
*info = -20;
} else /* if(complicated condition) */ {
/* Computing MAX */
/* Computing 2nd power */
i__3 = nmax;
i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
if (max(i__1,i__2) > *lwork) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVSX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L150;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L130;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1.f, a[i__4].i = 0.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
&iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
if (n >= 4) {
claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___31.ciunit = *nounit;
s_wsfe(&io___31);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else {
/* Computing MAX */
i__3 = n << 1, i__4 = n * (n + 1) / 2;
nnwork = max(i__3,i__4);
}
nnwork = max(nnwork,1);
cget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
a_offset], lda, &h__[h_offset], &ht[ht_offset], &w[1],
&wt[1], &wtmp[1], &vs[vs_offset], ldvs, &vs1[
vs1_offset], &rcdein, &rcdvin, &nslct, islct, &c__0, &
result[1], &work[1], &nnwork, &rwork[1], &bwork[1],
info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 15; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___41.ciunit = *nounit;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 15; ++j) {
if (result[j] >= *thresh) {
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
);
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
L130:
;
}
/* L140: */
}
L150:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
jtype = 0;
L160:
io___47.ciunit = *niunit;
i__1 = s_rsle(&io___47);
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L200;
}
if (n == 0) {
goto L200;
}
++jtype;
iseed[1] = jtype;
io___49.ciunit = *niunit;
s_rsle(&io___49);
i__1 = nslct;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___51.ciunit = *niunit;
s_rsle(&io___51);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
complex));
}
e_rsle();
/* L170: */
}
io___52.ciunit = *niunit;
s_rsle(&io___52);
do_lio(&c__4, &c__1, (char *)&rcdein, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin, (ftnlen)sizeof(real));
e_rsle();
cget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
&h__[h_offset], &ht[ht_offset], &w[1], &wt[1], &wtmp[1], &vs[
vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin, &nslct,
islct, &isrt, &result[1], &work[1], lwork, &rwork[1], &bwork[1],
info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 17; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L180: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 17; ++j) {
if (result[j] >= *thresh) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
/* L190: */
}
nerrs += nfail;
ntestt += ntest;
goto L160;
L200:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of CDRVSX */
} /* cdrvsx_ */
/* Subroutine */ int dget36_(doublereal *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j, n;
doublereal q[100] /* was [10][10] */, t1[100] /* was [10][10] */,
t2[100] /* was [10][10] */;
integer loc;
doublereal eps, res, tmp[100] /* was [10][10] */;
integer ifst, ilst;
doublereal work[200];
integer info1, info2, ifst1, ifst2, ilst1, ilst2;
extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dtrexc_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
integer ifstsv;
doublereal result[2];
integer ilstsv;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or */
/* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, DLAEXC */
/* computes an orthogonal matrix Q such that */
/* Q' * T1 * Q = T2 */
/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
/* been moved to position ILST. */
/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
/* is in Schur form, and that the final position of the IFST block is */
/* ILST (within +-1). */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) DOUBLE PRECISION */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER array, dimension (3) */
/* NINFO(J) is the number of examples where INFO=J. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ninfo;
/* Function Body */
eps = dlamch_("P");
*rmax = 0.;
*lmax = 0;
*knt = 0;
ninfo[1] = 0;
ninfo[2] = 0;
ninfo[3] = 0;
/* Read input data until N=0 */
L10:
io___2.ciunit = *nin;
s_rsle(&io___2);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
++(*knt);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___7.ciunit = *nin;
s_rsle(&io___7);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L20: */
}
dlacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
dlacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
ifstsv = ifst;
ilstsv = ilst;
ifst1 = ifst;
ilst1 = ilst;
ifst2 = ifst;
ilst2 = ilst;
res = 0.;
/* Test without accumulating Q */
dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
dtrexc_("N", &n, t1, &c__10, q, &c__10, &ifst1, &ilst1, work, &info1);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j && q[i__ + j * 10 - 11] != 1.) {
res += 1. / eps;
}
if (i__ != j && q[i__ + j * 10 - 11] != 0.) {
res += 1. / eps;
}
/* L30: */
}
/* L40: */
}
/* Test with accumulating Q */
dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
dtrexc_("V", &n, t2, &c__10, q, &c__10, &ifst2, &ilst2, work, &info2);
/* Compare T1 with T2 */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
if (t1[i__ + j * 10 - 11] != t2[i__ + j * 10 - 11]) {
res += 1. / eps;
}
/* L50: */
}
/* L60: */
}
if (ifst1 != ifst2) {
res += 1. / eps;
}
if (ilst1 != ilst2) {
res += 1. / eps;
}
if (info1 != info2) {
res += 1. / eps;
}
/* Test for successful reordering of T2 */
if (info2 != 0) {
++ninfo[info2];
} else {
if ((i__1 = ifst2 - ifstsv, abs(i__1)) > 1) {
res += 1. / eps;
}
if ((i__1 = ilst2 - ilstsv, abs(i__1)) > 1) {
res += 1. / eps;
}
}
/* Test for small residual, and orthogonality of Q */
dhst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
result);
res = res + result[0] + result[1];
/* Test for T2 being in Schur form */
loc = 1;
L70:
if (t2[loc + 1 + loc * 10 - 11] != 0.) {
/* 2 by 2 block */
if (t2[loc + (loc + 1) * 10 - 11] == 0. || t2[loc + loc * 10 - 11] !=
t2[loc + 1 + (loc + 1) * 10 - 11] || d_sign(&c_b22, &t2[loc +
(loc + 1) * 10 - 11]) == d_sign(&c_b22, &t2[loc + 1 + loc *
10 - 11])) {
res += 1. / eps;
}
i__1 = n;
for (i__ = loc + 2; i__ <= i__1; ++i__) {
if (t2[i__ + loc * 10 - 11] != 0.) {
res += 1. / res;
}
if (t2[i__ + (loc + 1) * 10 - 11] != 0.) {
res += 1. / res;
}
/* L80: */
}
loc += 2;
} else {
/* 1 by 1 block */
i__1 = n;
for (i__ = loc + 1; i__ <= i__1; ++i__) {
if (t2[i__ + loc * 10 - 11] != 0.) {
res += 1. / res;
}
/* L90: */
}
++loc;
}
if (loc < n) {
goto L70;
}
if (res > *rmax) {
*rmax = res;
*lmax = *knt;
}
goto L10;
/* End of DGET36 */
} /* dget36_ */
/* Subroutine */ int cget36_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, j, n;
complex q[100] /* was [10][10] */, t1[100] /* was [10][10] */,
t2[100] /* was [10][10] */;
real eps, res;
complex tmp[100] /* was [10][10] */, diag[10];
integer ifst, ilst;
complex work[200];
integer info1, info2;
extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *);
complex ctemp;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
real rwork[10];
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), ctrexc_(char *, integer *, complex *, integer *, complex
*, integer *, integer *, integer *, integer *);
real result[2];
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGET36 tests CTREXC, a routine for reordering diagonal entries of a */
/* matrix in complex Schur form. Thus, CLAEXC computes a unitary matrix */
/* Q such that */
/* Q' * T1 * Q = T2 */
/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
/* been moved to position ILST. */
/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
/* is in Schur form, and that the final position of the IFST block is */
/* ILST. */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) REAL */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER */
/* Number of examples where INFO is nonzero. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
eps = slamch_("P");
*rmax = 0.f;
*lmax = 0;
*knt = 0;
*ninfo = 0;
/* Read input data until N=0 */
L10:
io___2.ciunit = *nin;
s_rsle(&io___2);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
++(*knt);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___7.ciunit = *nin;
s_rsle(&io___7);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L20: */
}
clacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
clacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
res = 0.f;
/* Test without accumulating Q */
claset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ctrexc_("N", &n, t1, &c__10, q, &c__10, &ifst, &ilst, &info1);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
if (i__ == j && (q[i__3].r != 1.f || q[i__3].i != 0.f)) {
res += 1.f / eps;
}
i__3 = i__ + j * 10 - 11;
if (i__ != j && (q[i__3].r != 0.f || q[i__3].i != 0.f)) {
res += 1.f / eps;
}
/* L30: */
}
/* L40: */
}
/* Test with accumulating Q */
claset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ctrexc_("V", &n, t2, &c__10, q, &c__10, &ifst, &ilst, &info2);
/* Compare T1 with T2 */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
if (t1[i__3].r != t2[i__4].r || t1[i__3].i != t2[i__4].i) {
res += 1.f / eps;
}
/* L50: */
}
/* L60: */
}
if (info1 != 0 || info2 != 0) {
++(*ninfo);
}
if (info1 != info2) {
res += 1.f / eps;
}
/* Test for successful reordering of T2 */
ccopy_(&n, tmp, &c__11, diag, &c__1);
if (ifst < ilst) {
i__1 = ilst;
for (i__ = ifst + 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__ - 1;
i__3 = i__ - 2;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 2;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L70: */
}
} else if (ifst > ilst) {
i__1 = ilst;
for (i__ = ifst - 1; i__ >= i__1; --i__) {
i__2 = i__;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__;
i__3 = i__ - 1;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 1;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L80: */
}
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * 10 - 11;
i__3 = i__ - 1;
if (t2[i__2].r != diag[i__3].r || t2[i__2].i != diag[i__3].i) {
res += 1.f / eps;
}
/* L90: */
}
/* Test for small residual, and orthogonality of Q */
chst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
rwork, result);
res = res + result[0] + result[1];
/* Test for T2 being in Schur form */
i__1 = n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 10 - 11;
if (t2[i__3].r != 0.f || t2[i__3].i != 0.f) {
res += 1.f / eps;
}
/* L100: */
}
/* L110: */
}
if (res > *rmax) {
*rmax = res;
*lmax = *knt;
}
goto L10;
/* End of CGET36 */
} /* cget36_ */
/* Subroutine */ int dchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of DGGBAL .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9993[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
char *, ftnlen);
/* Local variables */
static integer info, lmax[5];
static doublereal rmax, vmax, work[120], a[400] /* was [20][20] */, b[
400] /* was [20][20] */;
static integer i__, j, n, ihiin, ninfo, iloin;
static doublereal anorm, bnorm;
extern /* Subroutine */ int dggbal_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static doublereal lscale[20], rscale[20], lsclin[20], rsclin[20], ain[400]
/* was [20][20] */, bin[400] /* was [20][20] */;
static integer ihi, ilo;
static doublereal eps;
static integer knt;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
#define a_ref(a_1,a_2) a[(a_2)*20 + a_1 - 21]
#define b_ref(a_1,a_2) b[(a_2)*20 + a_1 - 21]
#define ain_ref(a_1,a_2) ain[(a_2)*20 + a_1 - 21]
#define bin_ref(a_1,a_2) bin[(a_2)*20 + a_1 - 21]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DCHKGL tests DGGBAL, a routine for balancing a matrix pair (A, B).
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
===================================================================== */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&ain_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&bin_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = dlange_("M", &n, &n, a, &c__20, work);
bnorm = dlange_("M", &n, &n, b, &c__20, work);
++knt;
dggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = a_ref(i__, j) - ain_ref(i__, j), abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = b_ref(i__, j) - bin_ref(i__, j), abs(
d__1));
vmax = max(d__2,d__3);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of DCHKGL */
} /* dchkgl_ */
/* Subroutine */ int ddrgsx_(integer *nsize, integer *ncmax, doublereal *
thresh, integer *nin, integer *nout, doublereal *a, integer *lda,
doublereal *b, doublereal *ai, doublereal *bi, doublereal *z__,
doublereal *q, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *c__, integer *ldc, doublereal *s, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, logical *bwork,
integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 DDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9997[] = "(\002 DDRGSX: DGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002)\002)";
static char fmt_9996[] = "(\002 DDRGSX: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
")\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
"form\002,\002 problem driver\002)";
static char fmt_9993[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
"ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
"ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
"angular matrices, \002,/\002 3: A and B are as type 2, but eac"
"h second diagonal \002,\002block in A_11 and \002,/\002 eac"
"h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
"and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
"entially close or common \002,\002eigenvalues.\002,/)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
"pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
" = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
"Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
"\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
"lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
"S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
"agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
"t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
"if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
"SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
"PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
"est 10 is only for input examples )\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,d10.4)";
static char fmt_9998[] = "(\002 DDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
")\002)";
static char fmt_9994[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, i1, mm;
doublereal pl[2];
integer mn2, qba, qbb;
doublereal ulp, temp1, temp2;
extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dget53_(
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal abnrm;
integer ifunc, iinfo, linfo;
char sense[1];
integer nerrs, ntest;
extern /* Subroutine */ int dlakf2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *);
doublereal pltru;
extern /* Subroutine */ int dlatm5_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *), dlabad_(
doublereal *, doublereal *);
doublereal thrsh2;
logical ilabad;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
integer bdspac;
extern /* Subroutine */ int dgesvd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *);
doublereal difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal bignum;
extern /* Subroutine */ int dggesx_(char *, char *, char *, L_fp, char *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, logical *, integer
*), alasvm_(char *, integer *,
integer *, integer *, integer *), xerbla_(char *, integer
*);
doublereal weight, diftru;
extern logical dlctsx_();
integer minwrk, maxwrk;
doublereal smlnum, ulpinv;
integer nptknt;
doublereal result[10];
integer ntestt, prtype;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___42 = { 0, 0, 1, 0, 0 };
static cilist io___43 = { 0, 0, 1, 0, 0 };
static cilist io___44 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, 0, 0 };
static cilist io___46 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRGSX checks the nonsymmetric generalized eigenvalue (Schur form) */
/* problem expert driver DGGESX. */
/* DGGESX factors A and B as Q S Z' and Q T Z', where ' means */
/* transpose, T is upper triangular, S is in generalized Schur form */
/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
/* the 2x2 blocks corresponding to complex conjugate pairs of */
/* generalized eigenvalues), and Q and Z are orthogonal. It also */
/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the */
/* characteristic equation */
/* det( A - w(j) B ) = 0 */
/* Optionally it also reorders the eigenvalues so that a selected */
/* cluster of eigenvalues appears in the leading diagonal block of the */
/* Schur forms; computes a reciprocal condition number for the average */
/* of the selected eigenvalues; and computes a reciprocal condition */
/* number for the right and left deflating subspaces corresponding to */
/* the selected eigenvalues. */
/* When DDRGSX is called with NSIZE > 0, five (5) types of built-in */
/* matrix pairs are used to test the routine DGGESX. */
/* When DDRGSX is called with NSIZE = 0, it reads in test matrix data */
/* to test DGGESX. */
/* For each matrix pair, the following tests will be performed and */
/* compared with the threshhold THRESH except for the tests (7) and (9): */
/* (1) | A - Q S Z' | / ( |A| n ulp ) */
/* (2) | B - Q T Z' | / ( |B| n ulp ) */
/* (3) | I - QQ' | / ( n ulp ) */
/* (4) | I - ZZ' | / ( n ulp ) */
/* (5) if A is in Schur form (i.e. quasi-triangular form) */
/* (6) maximum over j of D(j) where: */
/* if alpha(j) is real: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* if alpha(j) is complex: */
/* | det( s S - w T ) | */
/* D(j) = --------------------------------------------------- */
/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
/* and S and T are here the 2 x 2 diagonal blocks of S and T */
/* corresponding to the j-th and j+1-th eigenvalues. */
/* (7) if sorting worked and SDIM is the number of eigenvalues */
/* which were selected. */
/* (8) the estimated value DIF does not differ from the true values of */
/* Difu and Difl more than a factor 10*THRESH. If the estimate DIF */
/* equals zero the corresponding true values of Difu and Difl */
/* should be less than EPS*norm(A, B). If the true value of Difu */
/* and Difl equal zero, the estimate DIF should be less than */
/* EPS*norm(A, B). */
/* (9) If INFO = N+3 is returned by DGGESX, the reordering "failed" */
/* and we check that DIF = PL = PR = 0 and that the true value of */
/* Difu and Difl is < EPS*norm(A, B). We count the events when */
/* INFO=N+3. */
/* For read-in test matrices, the above tests are run except that the */
/* exact value for DIF (and PL) is input data. Additionally, there is */
/* one more test run for read-in test matrices: */
/* (10) the estimated value PL does not differ from the true value of */
/* PLTRU more than a factor THRESH. If the estimate PL equals */
/* zero the corresponding true value of PLTRU should be less than */
/* EPS*norm(A, B). If the true value of PLTRU equal zero, the */
/* estimate PL should be less than EPS*norm(A, B). */
/* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1) */
/* matrix pairs are generated and tested. NSIZE should be kept small. */
/* SVD (routine DGESVD) is used for computing the true value of DIF_u */
/* and DIF_l when testing the built-in test problems. */
/* Built-in Test Matrices */
/* ====================== */
/* All built-in test matrices are the 2 by 2 block of triangular */
/* matrices */
/* A = [ A11 A12 ] and B = [ B11 B12 ] */
/* [ A22 ] [ B22 ] */
/* where for different type of A11 and A22 are given as the following. */
/* A12 and B12 are chosen so that the generalized Sylvester equation */
/* A11*R - L*A22 = -A12 */
/* B11*R - L*B22 = -B12 */
/* have prescribed solution R and L. */
/* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1). */
/* B11 = I_m, B22 = I_k */
/* where J_k(a,b) is the k-by-k Jordan block with ``a'' on */
/* diagonal and ``b'' on superdiagonal. */
/* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and */
/* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m */
/* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and */
/* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k */
/* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each */
/* second diagonal block in A_11 and each third diagonal block */
/* in A_22 are made as 2 by 2 blocks. */
/* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) ) */
/* for i=1,...,m, j=1,...,m and */
/* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) ) */
/* for i=m+1,...,k, j=m+1,...,k */
/* Type 5: (A,B) and have potentially close or common eigenvalues and */
/* very large departure from block diagonality A_11 is chosen */
/* as the m x m leading submatrix of A_1: */
/* | 1 b | */
/* | -b 1 | */
/* | 1+d b | */
/* | -b 1+d | */
/* A_1 = | d 1 | */
/* | -1 d | */
/* | -d 1 | */
/* | -1 -d | */
/* | 1 | */
/* and A_22 is chosen as the k x k leading submatrix of A_2: */
/* | -1 b | */
/* | -b -1 | */
/* | 1-d b | */
/* | -b 1-d | */
/* A_2 = | d 1+b | */
/* | -1-b d | */
/* | -d 1+b | */
/* | -1+b -d | */
/* | 1-d | */
/* and matrix B are chosen as identity matrices (see DLATM5). */
/* Arguments */
/* ========= */
/* NSIZE (input) INTEGER */
/* The maximum size of the matrices to use. NSIZE >= 0. */
/* If NSIZE = 0, no built-in tests matrices are used, but */
/* read-in test matrices are used to test DGGESX. */
/* NCMAX (input) INTEGER */
/* Maximum allowable NMAX for generating Kroneker matrix */
/* in call to DLAKF2 */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. THRESH >= 0. */
/* NIN (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Used to store the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, AI, BI, Z and Q, */
/* LDA >= max( 1, NSIZE ). For the read-in test, */
/* LDA >= max( 1, N ), N is the size of the test matrices. */
/* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Used to store the matrix whose eigenvalues are to be */
/* computed. On exit, B contains the last matrix actually used. */
/* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Copy of A, modified by DGGESX. */
/* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Copy of B, modified by DGGESX. */
/* Z (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Z holds the left Schur vectors computed by DGGESX. */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Q holds the right Schur vectors computed by DGGESX. */
/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
/* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
/* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues. */
/* C (workspace) DOUBLE PRECISION array, dimension (LDC, LDC) */
/* Store the matrix generated by subroutine DLAKF2, this is the */
/* matrix formed by Kronecker products used for estimating */
/* DIF. */
/* LDC (input) INTEGER */
/* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ). */
/* S (workspace) DOUBLE PRECISION array, dimension (LDC) */
/* Singular values of C */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) ) */
/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= NSIZE + 6. */
/* BWORK (workspace) LOGICAL array, dimension (LDA) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--alphar;
--alphai;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--s;
--work;
--iwork;
--bwork;
/* Function Body */
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < *nsize) {
*info = -6;
} else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
*info = -17;
} else if (*liwork < *nsize + 6) {
*info = -21;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* Computing MAX */
i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
minwrk = max(i__1,i__2);
/* workspace for sggesx */
maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "DGEQRF", " ",
nsize, &c__1, nsize, &c__0);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
"DORGQR", " ", nsize, &c__1, nsize, &c_n1);
maxwrk = max(i__1,i__2);
/* workspace for dgesvd */
bdspac = *nsize * 5 * *nsize / 2;
/* Computing MAX */
i__3 = *nsize * *nsize / 2;
i__4 = *nsize * *nsize / 2;
i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize *
ilaenv_(&c__1, "DGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
maxwrk = max(maxwrk,minwrk);
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRGSX", &i__1);
return 0;
}
/* Important constants */
ulp = dlamch_("P");
ulpinv = 1. / ulp;
smlnum = dlamch_("S") / ulp;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
thrsh2 = *thresh * 10.;
ntestt = 0;
nerrs = 0;
/* Go to the tests for read-in matrix pairs */
ifunc = 0;
if (*nsize == 0) {
goto L70;
}
/* Test the built-in matrix pairs. */
/* Loop over different functions (IFUNC) of DGGESX, types (PRTYPE) */
/* of test matrices, different size (M+N) */
prtype = 0;
qba = 3;
qbb = 4;
weight = sqrt(ulp);
for (ifunc = 0; ifunc <= 3; ++ifunc) {
for (prtype = 1; prtype <= 5; ++prtype) {
i__1 = *nsize - 1;
for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
i__2 = *nsize - mn_1.m;
for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
weight = 1. / weight;
mn_1.mplusn = mn_1.m + mn_1.n;
/* Generate test matrices */
mn_1.fs = TRUE_;
mn_1.k = 0;
dlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &ai[ai_offset], lda);
dlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &bi[bi_offset], lda);
dlatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
ai[mn_1.m + 1 + (mn_1.m + 1) * ai_dim1], lda, &ai[
(mn_1.m + 1) * ai_dim1 + 1], lda, &bi[bi_offset],
lda, &bi[mn_1.m + 1 + (mn_1.m + 1) * bi_dim1],
lda, &bi[(mn_1.m + 1) * bi_dim1 + 1], lda, &q[
q_offset], lda, &z__[z_offset], lda, &weight, &
qba, &qbb);
/* Compute the Schur factorization and swapping the */
/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
/* Swapping is accomplished via the function DLCTSX */
/* which is supplied below. */
if (ifunc == 0) {
*(unsigned char *)sense = 'N';
} else if (ifunc == 1) {
*(unsigned char *)sense = 'E';
} else if (ifunc == 2) {
*(unsigned char *)sense = 'V';
} else if (ifunc == 3) {
*(unsigned char *)sense = 'B';
}
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &a[a_offset], lda);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &b[b_offset], lda);
dggesx_("V", "V", "S", (L_fp)dlctsx_, sense, &mn_1.mplusn,
&ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
alphar[1], &alphai[1], &beta[1], &q[q_offset],
lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "DGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
);
e_wsfe();
*info = linfo;
goto L30;
}
/* Compute the norm(A, B) */
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &work[1], &mn_1.mplusn);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
mn_1.mplusn);
i__3 = mn_1.mplusn << 1;
abnrm = dlange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
mn_1.mplusn, &work[1]);
/* Do tests (1) to (4) */
dget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], result);
dget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &result[1]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &q[q_offset],
lda, &work[1], &result[2]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &z__[z_offset], lda, &z__[
z_offset], lda, &work[1], &result[3]);
ntest = 4;
/* Do tests (5) and (6): check Schur form of A and */
/* compare eigenvalues with diagonals. */
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__3 = mn_1.mplusn;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.) {
/* Computing MAX */
d__7 = smlnum, d__8 = (d__2 = alphar[j], abs(d__2)
), d__7 = max(d__7,d__8), d__8 = (d__3 =
ai[j + j * ai_dim1], abs(d__3));
/* Computing MAX */
d__9 = smlnum, d__10 = (d__5 = beta[j], abs(d__5))
, d__9 = max(d__9,d__10), d__10 = (d__6 =
bi[j + j * bi_dim1], abs(d__6));
temp2 = ((d__1 = alphar[j] - ai[j + j * ai_dim1],
abs(d__1)) / max(d__7,d__8) + (d__4 =
beta[j] - bi[j + j * bi_dim1], abs(d__4))
/ max(d__9,d__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai[j + 1 + j * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai[j + (j - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai[i1 + (i1 - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
dget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 +
i1 * bi_dim1], lda, &beta[j], &alphar[
j], &alphai[j], &temp2, &iinfo);
if (iinfo >= 3) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L10: */
}
result[5] = temp1;
ntest += 2;
/* Test (7) (if sorting worked) */
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
} else if (mm != mn_1.n) {
result[6] = ulpinv;
}
++ntest;
/* Test (8): compare the estimated value DIF and its */
/* value. first, compute the exact DIF. */
result[7] = 0.;
mn2 = mm * (mn_1.mplusn - mm) << 1;
if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
/* Note: for either following two causes, there are */
/* almost same number of test cases fail the test. */
i__3 = mn_1.mplusn - mm;
dlakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai[mm + 1 +
(mm + 1) * ai_dim1], &bi[bi_offset], &bi[mm +
1 + (mm + 1) * bi_dim1], &c__[c_offset], ldc);
i__3 = *lwork - 2;
dgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
1], &work[1], &c__1, &work[2], &c__1, &work[3]
, &i__3, info);
diftru = s[mn2];
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru *
thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] /
diftru;
result[7] = max(d__1,d__2);
}
++ntest;
}
/* Test (9) */
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
++ntest;
}
ntestt += ntest;
/* Print out tests which fail. */
for (j = 1; j <= 9; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___36.ciunit = *nout;
s_wsfe(&io___36);
e_wsfe();
/* Tests performed */
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
}
/* L20: */
}
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
goto L150;
L70:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
nptknt = 0;
L80:
io___42.ciunit = *nin;
i__1 = s_rsle(&io___42);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
;
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
if (mn_1.mplusn == 0) {
goto L140;
}
io___43.ciunit = *nin;
i__1 = s_rsle(&io___43);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___44.ciunit = *nin;
s_rsle(&io___44);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&ai[i__ + j * ai_dim1], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L90: */
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___45.ciunit = *nin;
s_rsle(&io___45);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&bi[i__ + j * bi_dim1], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L100: */
}
io___46.ciunit = *nin;
s_rsle(&io___46);
do_lio(&c__5, &c__1, (char *)&pltru, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&diftru, (ftnlen)sizeof(doublereal));
e_rsle();
++nptknt;
mn_1.fs = TRUE_;
mn_1.k = 0;
mn_1.m = mn_1.mplusn - mn_1.n;
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
a_offset], lda);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
b_offset], lda);
/* Compute the Schur factorization while swaping the */
/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "DGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L130;
}
/* Compute the norm(A, B) */
/* (should this be norm of (A,B) or (AI,BI)?) */
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
&mn_1.mplusn);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
i__1 = mn_1.mplusn << 1;
abnrm = dlange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
1]);
/* Do tests (1) to (4) */
dget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], result);
dget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);
/* Do tests (5) and (6): check Schur form of A and compare */
/* eigenvalues with diagonals. */
ntest = 6;
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__1 = mn_1.mplusn;
for (j = 1; j <= i__1; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.) {
/* Computing MAX */
d__7 = smlnum, d__8 = (d__2 = alphar[j], abs(d__2)), d__7 = max(
d__7,d__8), d__8 = (d__3 = ai[j + j * ai_dim1], abs(d__3))
;
/* Computing MAX */
d__9 = smlnum, d__10 = (d__5 = beta[j], abs(d__5)), d__9 = max(
d__9,d__10), d__10 = (d__6 = bi[j + j * bi_dim1], abs(
d__6));
temp2 = ((d__1 = alphar[j] - ai[j + j * ai_dim1], abs(d__1)) /
max(d__7,d__8) + (d__4 = beta[j] - bi[j + j * bi_dim1],
abs(d__4)) / max(d__9,d__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai[j + 1 + j * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai[j + (j - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai[i1 + (i1 - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
dget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 + i1 * bi_dim1],
lda, &beta[j], &alphar[j], &alphai[j], &temp2, &iinfo)
;
if (iinfo >= 3) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L110: */
}
result[5] = temp1;
/* Test (7) (if sorting worked) <--------- need to be checked. */
ntest = 7;
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
}
/* Test (8): compare the estimated value of DIF and its true value. */
ntest = 8;
result[7] = 0.;
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] / diftru;
result[7] = max(d__1,d__2);
}
/* Test (9) */
ntest = 9;
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
}
/* Test (10): compare the estimated value of PL and it true value. */
ntest = 10;
result[9] = 0.;
if (pl[0] == 0.) {
if (pltru > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru == 0.) {
if (pl[0] > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
result[9] = ulpinv;
}
ntestt += ntest;
/* Print out tests which fail. */
i__1 = ntest;
for (j = 1; j <= i__1; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nout;
s_wsfe(&io___52);
e_wsfe();
/* Tests performed */
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L120: */
}
L130:
goto L80;
L140:
L150:
/* Summary */
alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);
work[1] = (doublereal) maxwrk;
return 0;
/* End of DDRGSX */
} /* ddrgsx_ */
/* Subroutine */ int sdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, real *a, integer *lda, real *h__, real *wr, real *wi,
real *wr1, real *wi1, real *vl, integer *ldvl, real *vr, integer *
ldvr, real *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
scale1, real *result, real *work, integer *nwork, integer *iwork,
integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
static char bal[1*4] = "N" "P" "S" "B";
/* Format strings */
static char fmt_9992[] = "(\002 SDRVVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Real Eigenvalue-Eigenvector De"
"composition\002,\002 Expert Driver\002,/\002 Matrix types (see S"
"DRVVX for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
"22=Matrix read from input file\002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
"|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
"/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
"/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
"mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
"matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
" = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
"p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
"tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
"= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
"= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
"WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
"\002, test(\002,i2,\002)=\002,g10.3)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static integer ibal;
static real cond;
static integer jcol;
static char path[3];
static integer nmax;
static real unfl, ovfl;
static integer i__, j, n;
static logical badnn;
static integer nfail, imode, iinfo;
static real conds;
extern /* Subroutine */ int sget23_(logical *, char *, integer *, real *,
integer *, integer *, integer *, real *, integer *, real *, real *
, real *, real *, real *, real *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, real *, real *,
real *, real *, real *, real *, integer *, integer *, integer *);
static real anorm;
static integer jsize, nerrs, itype, jtype, ntest;
static real rtulp;
static char balanc[1];
extern /* Subroutine */ int slabad_(real *, real *);
static char adumma[1*1];
extern doublereal slamch_(char *);
static integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
integer *, real *, real *, char *, char *, char *, char *, real *,
integer *, real *, integer *, integer *, real *, real *, integer
*, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *), slatmr_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, char *, char *,
real *, integer *, real *, real *, integer *, real *, char *,
integer *, integer *, integer *, real *, real *, char *, real *,
integer *, integer *, integer *);
static integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*), slatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, real *, integer *, real *, integer *);
static real ulpinv;
static integer nnwork;
static real rtulpi;
static integer mtypes, ntestt, iwk;
static real ulp;
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___46 = { 0, 0, 1, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SDRVVX checks the nonsymmetric eigenvalue problem expert driver
SGEEVX.
SDRVVX uses both test matrices generated randomly depending on
data supplied in the calling sequence, as well as on data
read from an input file and including precomputed condition
numbers to which it compares the ones it computes.
When SDRVVX is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified in the calling sequence.
For each size ("n") and each type of matrix, one matrix will be
generated and used to test the nonsymmetric eigenroutines. For
each matrix, 9 tests will be performed:
(1) | A * VR - VR * W | / ( n |A| ulp )
Here VR is the matrix of unit right eigenvectors.
W is a block diagonal matrix, with a 1x1 block for each
real eigenvalue and a 2x2 block for each complex conjugate
pair. If eigenvalues j and j+1 are a complex conjugate pair,
so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
2 x 2 block corresponding to the pair will be:
( wr wi )
( -wi wr )
Such a block multiplying an n x 2 matrix ( ur ui ) on the
right will be the same as multiplying ur + i*ui by wr + i*wi.
(2) | A**H * VL - VL * W**H | / ( n |A| ulp )
Here VL is the matrix of unit left eigenvectors, A**H is the
conjugate transpose of A, and W is as above.
(3) | |VR(i)| - 1 | / ulp and largest component real
VR(i) denotes the i-th column of VR.
(4) | |VL(i)| - 1 | / ulp and largest component real
VL(i) denotes the i-th column of VL.
(5) W(full) = W(partial)
W(full) denotes the eigenvalues computed when VR, VL, RCONDV
and RCONDE are also computed, and W(partial) denotes the
eigenvalues computed when only some of VR, VL, RCONDV, and
RCONDE are computed.
(6) VR(full) = VR(partial)
VR(full) denotes the right eigenvectors computed when VL, RCONDV
and RCONDE are computed, and VR(partial) denotes the result
when only some of VL and RCONDV are computed.
(7) VL(full) = VL(partial)
VL(full) denotes the left eigenvectors computed when VR, RCONDV
and RCONDE are computed, and VL(partial) denotes the result
when only some of VR and RCONDV are computed.
(8) 0 if SCALE, ILO, IHI, ABNRM (full) =
SCALE, ILO, IHI, ABNRM (partial)
1/ulp otherwise
SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
(full) is when VR, VL, RCONDE and RCONDV are also computed, and
(partial) is when some are not computed.
(9) RCONDV(full) = RCONDV(partial)
RCONDV(full) denotes the reciprocal condition numbers of the
right eigenvectors computed when VR, VL and RCONDE are also
computed. RCONDV(partial) denotes the reciprocal condition
numbers when only some of VR, VL and RCONDE are computed.
The "sizes" are specified by an array NN(1:NSIZES); the value of
each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES );
if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) The zero matrix.
(2) The identity matrix.
(3) A (transposed) Jordan block, with 1's on the diagonal.
(4) A diagonal matrix with evenly spaced entries
1, ..., ULP and random signs.
(ULP = (first number larger than 1) - 1 )
(5) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(7) Same as (4), but multiplied by a constant near
the overflow threshold
(8) Same as (4), but multiplied by a constant near
the underflow threshold
(9) A matrix of the form U' T U, where U is orthogonal and
T has evenly spaced entries 1, ..., ULP with random signs
on the diagonal and random O(1) entries in the upper
triangle.
(10) A matrix of the form U' T U, where U is orthogonal and
T has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(11) A matrix of the form U' T U, where U is orthogonal and
T has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(12) A matrix of the form U' T U, where U is orthogonal and
T has real or complex conjugate paired eigenvalues randomly
chosen from ( ULP, 1 ) and random O(1) entries in the upper
triangle.
(13) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(14) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has geometrically spaced entries
1, ..., ULP with random signs on the diagonal and random
O(1) entries in the upper triangle.
(15) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(16) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has real or complex conjugate paired
eigenvalues randomly chosen from ( ULP, 1 ) and random
O(1) entries in the upper triangle.
(17) Same as (16), but multiplied by a constant
near the overflow threshold
(18) Same as (16), but multiplied by a constant
near the underflow threshold
(19) Nonsymmetric matrix with random entries chosen from (-1,1).
If N is at least 4, all entries in first two rows and last
row, and first column and last two columns are zero.
(20) Same as (19), but multiplied by a constant
near the overflow threshold
(21) Same as (19), but multiplied by a constant
near the underflow threshold
In addition, an input file will be read from logical unit number
NIUNIT. The file contains matrices along with precomputed
eigenvalues and reciprocal condition numbers for the eigenvalues
and right eigenvectors. For these matrices, in addition to tests
(1) to (9) we will compute the following two tests:
(10) |RCONDV - RCDVIN| / cond(RCONDV)
RCONDV is the reciprocal right eigenvector condition number
computed by SGEEVX and RCDVIN (the precomputed true value)
is supplied as input. cond(RCONDV) is the condition number of
RCONDV, and takes errors in computing RCONDV into account, so
that the resulting quantity should be O(ULP). cond(RCONDV) is
essentially given by norm(A)/RCONDE.
(11) |RCONDE - RCDEIN| / cond(RCONDE)
RCONDE is the reciprocal eigenvalue condition number
computed by SGEEVX and RCDEIN (the precomputed true value)
is supplied as input. cond(RCONDE) is the condition number
of RCONDE, and takes errors in computing RCONDE into account,
so that the resulting quantity should be O(ULP). cond(RCONDE)
is essentially given by norm(A)/RCONDV.
Arguments
==========
NSIZES (input) INTEGER
The number of sizes of matrices to use. NSIZES must be at
least zero. If it is zero, no randomly generated matrices
are tested, but any test matrices read from NIUNIT will be
tested.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. The values must be at least
zero.
NTYPES (input) INTEGER
The number of elements in DOTYPE. NTYPES must be at least
zero. If it is zero, no randomly generated test matrices
are tested, but and test matrices read from NIUNIT will be
tested. If it is MAXTYP+1 and NSIZES is 1, then an
additional type, MAXTYP+1 is defined, which is to use
whatever matrix is in A. This is only useful if
DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to SDRVVX to continue the same random number
sequence.
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. It must be at least zero.
NIUNIT (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns INFO not equal to 0.)
A (workspace) REAL array, dimension
(LDA, max(NN,12))
Used to hold the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of the arrays A and H.
LDA >= max(NN,12), since 12 is the dimension of the largest
matrix in the precomputed input file.
H (workspace) REAL array, dimension
(LDA, max(NN,12))
Another copy of the test matrix A, modified by SGEEVX.
WR (workspace) REAL array, dimension (max(NN))
WI (workspace) REAL array, dimension (max(NN))
The real and imaginary parts of the eigenvalues of A.
On exit, WR + WI*i are the eigenvalues of the matrix in A.
WR1 (workspace) REAL array, dimension (max(NN,12))
WI1 (workspace) REAL array, dimension (max(NN,12))
Like WR, WI, these arrays contain the eigenvalues of A,
but those computed when SGEEVX only computes a partial
eigendecomposition, i.e. not the eigenvalues and left
and right eigenvectors.
VL (workspace) REAL array, dimension
(LDVL, max(NN,12))
VL holds the computed left eigenvectors.
LDVL (input) INTEGER
Leading dimension of VL. Must be at least max(1,max(NN,12)).
VR (workspace) REAL array, dimension
(LDVR, max(NN,12))
VR holds the computed right eigenvectors.
LDVR (input) INTEGER
Leading dimension of VR. Must be at least max(1,max(NN,12)).
LRE (workspace) REAL array, dimension
(LDLRE, max(NN,12))
LRE holds the computed right or left eigenvectors.
LDLRE (input) INTEGER
Leading dimension of LRE. Must be at least max(1,max(NN,12))
RCONDV (workspace) REAL array, dimension (N)
RCONDV holds the computed reciprocal condition numbers
for eigenvectors.
RCNDV1 (workspace) REAL array, dimension (N)
RCNDV1 holds more computed reciprocal condition numbers
for eigenvectors.
RCDVIN (workspace) REAL array, dimension (N)
When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
condition numbers for eigenvectors to be compared with
RCONDV.
RCONDE (workspace) REAL array, dimension (N)
RCONDE holds the computed reciprocal condition numbers
for eigenvalues.
RCNDE1 (workspace) REAL array, dimension (N)
RCNDE1 holds more computed reciprocal condition numbers
for eigenvalues.
RCDEIN (workspace) REAL array, dimension (N)
When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
condition numbers for eigenvalues to be compared with
RCONDE.
RESULT (output) REAL array, dimension (11)
The values computed by the seven tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
WORK (workspace) REAL array, dimension (NWORK)
NWORK (input) INTEGER
The number of entries in WORK. This must be at least
max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) =
max( 360 ,6*NN(j)+2*NN(j)**2) for all j.
IWORK (workspace) INTEGER array, dimension (2*max(NN,12))
INFO (output) INTEGER
If 0, then successful exit.
If <0, then input paramter -INFO is incorrect.
If >0, SLATMR, SLATMS, SLATME or SGET23 returned an error
code, and INFO is its absolute value.
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
NMAX Largest value in NN or 12.
NERRS The number of tests which have exceeded THRESH
COND, CONDS,
IMODE Values to be passed to the matrix generators.
ANORM Norm of A; passed to matrix generators.
OVFL, UNFL Overflow and underflow thresholds.
ULP, ULPINV Finest relative precision and its inverse.
RTULP, RTULPI Square roots of the previous 4 values.
The following four arrays decode JTYPE:
KTYPE(j) The general type (1-10) for type "j".
KMODE(j) The MODE value to be passed to the matrix
generator for type "j".
KMAGN(j) The order of magnitude ( O(1),
O(overflow^(1/2) ), O(underflow^(1/2) )
KCONDS(j) Selectw whether CONDS is to be 1 or
1/sqrt(ulp). (0 means irrelevant.)
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--wr;
--wi;
--wr1;
--wi1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1 * 1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--iwork;
/* Function Body */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed
problems */
nmax = 12;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -17;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -19;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -21;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
*info = -32;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVVX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L160;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L140;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A"
Control parameters:
KMAGN KCONDS KMODE KTYPE
=1 O(1) 1 clustered 1 zero
=2 large large clustered 2 identity
=3 small exponential Jordan
=4 arithmetic diagonal, (w/ eigenvalues)
=5 random log symmetric, w/ eigenvalues
=6 random general, w/ eigenvalues
=7 random diagonal
=8 random symmetric
=9 random general
=10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block
Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
if (jcol > 1) {
a_ref(jcol, jcol - 1) = 1.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
*(unsigned char *)&adumma[0] = ' ';
slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a_ref(3, 1)
, lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a_ref(3, n
- 1), lda);
slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a_ref(n, 1),
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___33.ciunit = *nounit;
s_wsfe(&io___33);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 3; ++iwk) {
if (iwk == 1) {
nnwork = n * 3;
} else if (iwk == 2) {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + i__3 * i__3;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Test for all balancing options */
for (ibal = 1; ibal <= 4; ++ibal) {
*(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
1];
/* Perform tests */
sget23_(&c_false, balanc, &jtype, thresh, ioldsd, nounit,
&n, &a[a_offset], lda, &h__[h_offset], &wr[1], &
wi[1], &wr1[1], &wi1[1], &vl[vl_offset], ldvl, &
vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &
rcnde1[1], &rcdein[1], &scale[1], &scale1[1], &
result[1], &work[1], &nnwork, &iwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 9; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___41.ciunit = *nounit;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real)
);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 9; ++j) {
if (result[j] >= *thresh) {
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, balanc, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
/* L130: */
}
L140:
;
}
/* L150: */
}
L160:
/* Read in data from file to check accuracy of condition estimation.
Assume input eigenvalues are sorted lexicographically (increasing
by real part, then decreasing by imaginary part) */
jtype = 0;
L170:
io___46.ciunit = *niunit;
i__1 = s_rsle(&io___46);
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L220;
}
/* Read input data until N=0 */
if (n == 0) {
goto L220;
}
++jtype;
iseed[1] = jtype;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___48.ciunit = *niunit;
s_rsle(&io___48);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(real))
;
}
e_rsle();
/* L180: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
do_lio(&c__4, &c__1, (char *)&wr1[i__], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wi1[i__], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(real));
e_rsle();
/* L190: */
}
/* Computing 2nd power */
i__2 = n;
i__1 = n * 6 + (i__2 * i__2 << 1);
sget23_(&c_true, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset],
lda, &h__[h_offset], &wr[1], &wi[1], &wr1[1], &wi1[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
rcdein[1], &scale[1], &scale1[1], &result[1], &work[1], &i__1, &
iwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 11; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L200: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
e_wsfe();
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 11; ++j) {
if (result[j] >= *thresh) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
/* L210: */
}
nerrs += nfail;
ntestt += ntest;
goto L170;
L220:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of SDRVVX */
} /* sdrvvx_ */
/* Subroutine */ int zchkbk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9994[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Local variables */
doublecomplex e[400] /* was [20][20] */;
integer i__, j, n;
doublereal x;
integer ihi;
doublecomplex ein[400] /* was [20][20] */;
integer ilo;
doublereal eps;
integer knt, info, lmax[2];
doublereal rmax, vmax, scale[20];
integer ninfo;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublecomplex *, integer *,
integer *);
doublereal safmin;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKBK tests ZGEBAK, a routine for backward transformation of */
/* the computed right or left eigenvectors if the orginal matrix */
/* was preprocessed by balance subroutine ZGEBAL. */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("E");
safmin = dlamch_("S");
L10:
io___7.ciunit = *nin;
s_rsle(&io___7);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L60;
}
io___11.ciunit = *nin;
s_rsle(&io___11);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nin;
s_rsle(&io___14);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
++knt;
zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
)) / eps;
i__3 = i__ + j * 20 - 21;
if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e[i__ + j *
20 - 21]), abs(d__2)) > safmin) {
i__4 = i__ + j * 20 - 21;
x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e[i__ +
j * 20 - 21]), abs(d__4));
}
vmax = max(vmax,x);
/* L40: */
}
/* L50: */
}
if (vmax > rmax) {
lmax[1] = knt;
rmax = vmax;
}
goto L10;
L60:
io___22.ciunit = *nout;
s_wsfe(&io___22);
e_wsfe();
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBK */
} /* zchkbk_ */
/* Subroutine */ int schkbl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of SGEBAL .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,e12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9993[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2;
real r__1, r__2, r__3;
/* Local variables */
real a[400] /* was [20][20] */;
integer i__, j, n;
real ain[400] /* was [20][20] */;
integer ihi, ilo, knt, info, lmax[3];
real meps, temp, rmax, vmax, scale[20];
integer ihiin, ninfo, iloin;
real anorm, sfmin, dummy[1];
extern /* Subroutine */ int sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *);
real scalin[20];
extern doublereal slange_(char *, integer *, integer *, real *, integer *,
real *);
/* Fortran I/O blocks */
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKBL tests SGEBAL, a routine for balancing a general real */
/* matrix and isolating some of its eigenvalues. */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.f;
vmax = 0.f;
sfmin = slamch_("S");
meps = slamch_("E");
L10:
io___8.ciunit = *nin;
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L70;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = *nin;
s_rsle(&io___11);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
sizeof(real));
}
e_rsle();
/* L20: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
sizeof(real));
}
e_rsle();
/* L30: */
}
io___19.ciunit = *nin;
s_rsle(&io___19);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__4, &c__1, (char *)&scalin[i__ - 1], (ftnlen)sizeof(real));
}
e_rsle();
anorm = slange_("M", &n, &n, a, &c__20, dummy);
++knt;
sgebal_("B", &n, a, &c__20, &ilo, &ihi, scale, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
r__1 = a[i__ + j * 20 - 21], r__2 = ain[i__ + j * 20 - 21];
temp = dmax(r__1,r__2);
temp = dmax(temp,sfmin);
/* Computing MAX */
r__2 = vmax, r__3 = (r__1 = a[i__ + j * 20 - 21] - ain[i__ + j *
20 - 21], dabs(r__1)) / temp;
vmax = dmax(r__2,r__3);
/* L40: */
}
/* L50: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = scale[i__ - 1], r__2 = scalin[i__ - 1];
temp = dmax(r__1,r__2);
temp = dmax(temp,sfmin);
/* Computing MAX */
r__2 = vmax, r__3 = (r__1 = scale[i__ - 1] - scalin[i__ - 1], dabs(
r__1)) / temp;
vmax = dmax(r__2,r__3);
/* L60: */
}
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L70:
io___28.ciunit = *nout;
s_wsfe(&io___28);
e_wsfe();
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
e_wsfe();
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of SCHKBL */
} /* schkbl_ */
/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,d12.3)";
static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9992[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9991[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
doublecomplex a[2500] /* was [50][50] */, b[2500] /* was [50][
50] */, e[2500] /* was [50][50] */, f[2500] /* was [50][
50] */;
integer i__, j, m, n;
doublecomplex af[2500] /* was [50][50] */, bf[2500] /* was [50][
50] */, vl[2500] /* was [50][50] */, vr[2500] /* was [50][
50] */;
integer ihi, ilo;
doublereal eps;
doublecomplex vlf[2500] /* was [50][50] */;
integer knt;
doublecomplex vrf[2500] /* was [50][50] */;
integer info, lmax[4];
doublereal rmax, vmax;
doublecomplex work[2500] /* was [50][50] */;
integer ninfo;
doublereal anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
doublereal rwork[300];
extern doublereal dlamch_(char *);
doublereal lscale[50];
extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zggbal_(char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal rscale[50];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGK tests ZGGBAK, a routine for backward balancing of */
/* a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L50: */
}
++knt;
anorm = zlange_("M", &n, &n, a, &c__50, rwork);
bnorm = zlange_("M", &n, &n, b, &c__50, rwork);
zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork,
&info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of ZGGBAK */
/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
/* where tilde(A) denotes the transformed matrix. */
zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 50 - 51;
i__4 = i__ + j * 50 - 51;
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L60: */
}
/* L70: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 50 - 51;
i__4 = i__ + j * 50 - 51;
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L80: */
}
/* L90: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___35.ciunit = *nout;
s_wsfe(&io___35);
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGK */
} /* zchkgk_ */
/* Subroutine */ int cchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(\002 .. test output of CGGBAL .. \002)";
static char fmt_9998[] = "(\002 ratio of largest test error "
" = \002,e12.3)";
static char fmt_9997[] = "(\002 example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong"
" = \002,i4)";
static char fmt_9995[] = "(\002 example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(\002 number of examples where info is not 0 "
" = \002,i4)";
static char fmt_9993[] = "(\002 total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
complex q__1;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double c_abs(complex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
complex a[400] /* was [20][20] */, b[400] /* was [20][20] */;
integer i__, j, n;
complex ain[400] /* was [20][20] */, bin[400] /* was [20][20] */;
integer ihi, ilo;
real eps;
integer knt, info, lmax[3];
real rmax, vmax, work[120];
integer ihiin, ninfo, iloin;
real anorm, bnorm;
extern /* Subroutine */ int cggbal_(char *, integer *, complex *, integer
*, complex *, integer *, integer *, integer *, real *, real *,
real *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
real lscale[20];
extern doublereal slamch_(char *);
real rscale[20], lsclin[20], rsclin[20];
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKGL tests CGGBAL, a routine for balancing a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.f;
eps = slamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__4, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(real));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__4, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(real));
}
e_rsle();
anorm = clange_("M", &n, &n, a, &c__20, work);
bnorm = clange_("M", &n, &n, b, &c__20, work);
++knt;
cggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
q__1.r = a[i__3].r - ain[i__4].r, q__1.i = a[i__3].i - ain[i__4]
.i;
r__1 = vmax, r__2 = c_abs(&q__1);
vmax = dmax(r__1,r__2);
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
q__1.r = b[i__3].r - bin[i__4].r, q__1.i = b[i__3].i - bin[i__4]
.i;
r__1 = vmax, r__2 = c_abs(&q__1);
vmax = dmax(r__1,r__2);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = vmax, r__3 = (r__1 = lscale[i__ - 1] - lsclin[i__ - 1], dabs(
r__1));
vmax = dmax(r__2,r__3);
/* Computing MAX */
r__2 = vmax, r__3 = (r__1 = rscale[i__ - 1] - rsclin[i__ - 1], dabs(
r__1));
vmax = dmax(r__2,r__3);
/* L80: */
}
vmax /= eps * dmax(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of CCHKGL */
} /* cchkgl_ */
/* Main program */ int MAIN__(void)
{
/* System generated locals */
integer i__1, i__2;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *), s_rsle(cilist *), e_rsle(void),
f_clos(cllist *), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static real a[1000000] /* was [1000][1000] */, b[1000];
static integer i__, j, k, n;
static real p[1000];
static char orientacao[6];
static real num;
static integer argc;
extern /* Subroutine */ int exit_(void);
static char nome_arquivo__[20];
extern integer iargc_(void), lucol_(integer *, integer *, real *, real *),
sscol_(integer *, integer *, real *, real *, real *), lurow_(
integer *, integer *, real *, real *), ssrow_(integer *, integer *
, real *, real *, real *);
extern /* Subroutine */ int getarg_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___4 = { 0, 6, 0, 0, 0 };
static cilist io___5 = { 0, 1, 0, 0, 0 };
static cilist io___8 = { 0, 1, 0, 0, 0 };
static cilist io___13 = { 0, 1, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
/* Matriz LU */
argc = iargc_();
if (argc > 1) {
getarg_(&c__1, nome_arquivo__, (ftnlen)20);
getarg_(&c__2, orientacao, (ftnlen)6);
} else {
s_wsle(&io___4);
do_lio(&c__9, &c__1, "Digite o nome do arquivo e se e orientada a li"
"nha ou coluna. (Ex: m1.dat linha)", (ftnlen)79);
e_wsle();
exit_();
}
o__1.oerr = 0;
o__1.ounit = 1;
o__1.ofnmlen = 20;
o__1.ofnm = nome_arquivo__;
o__1.orl = 0;
o__1.osta = "old";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
s_rsle(&io___5);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
/* Computing 2nd power */
i__2 = n;
i__1 = i__2 * i__2;
for (k = 1; k <= i__1; ++k) {
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&num, (ftnlen)sizeof(real));
e_rsle();
a[i__ + 1 + (j + 1) * 1000 - 1001] = num;
}
i__1 = n;
for (k = 1; k <= i__1; ++k) {
s_rsle(&io___13);
do_lio(&c__3, &c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&num, (ftnlen)sizeof(real));
e_rsle();
b[i__] = num;
}
cl__1.cerr = 0;
cl__1.cunit = 1;
cl__1.csta = 0;
f_clos(&cl__1);
/* ====================================================== */
/* OPERACAO POR LINHA */
if (s_cmp(orientacao, "linha", (ftnlen)6, (ftnlen)5) == 0 && lurow_(&n, &
c__1000, a, p) == -1) {
s_wsle(&io___16);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
if (s_cmp(orientacao, "linha", (ftnlen)6, (ftnlen)5) == 0 && ssrow_(&n, &
c__1000, a, p, b) == -1) {
s_wsle(&io___17);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
/* ====================================================== */
/* OPERACAO POR COLUNA */
if (s_cmp(orientacao, "coluna", (ftnlen)6, (ftnlen)6) == 0 && lucol_(&n, &
c__1000, a, p) == -1) {
s_wsle(&io___18);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
if (s_cmp(orientacao, "coluna", (ftnlen)6, (ftnlen)6) == 0 && sscol_(&n, &
c__1000, a, p, b) == -1) {
s_wsle(&io___19);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
/* ====================================================== */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
s_wsle(&io___20);
do_lio(&c__4, &c__1, (char *)&b[i__ - 1], (ftnlen)sizeof(real));
e_wsle();
}
return 0;
} /* MAIN__ */
