/* 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__ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
integer *n2, doublereal *work, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
an upper quasi-triangular matrix T by an orthogonal similarity
transformation.
T must be in Schur canonical form, that is, block upper triangular
with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
has its diagonal elemnts equal and its off-diagonal elements of
opposite sign.
Arguments
=========
WANTQ (input) LOGICAL
= .TRUE. : accumulate the transformation in the matrix Q;
= .FALSE.: do not accumulate the transformation.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
On entry, the upper quasi-triangular matrix T, in Schur
canonical form.
On exit, the updated matrix T, again in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
On exit, if WANTQ is .TRUE., the updated matrix Q.
If WANTQ is .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
J1 (input) INTEGER
The index of the first row of the first block T11.
N1 (input) INTEGER
The order of the first block T11. N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block T22. N2 = 0, 1 or 2.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
= 1: the transformed matrix T would be too far from Schur
form; the blocks are not swapped and T and Q are
unchanged.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__4 = 4;
static logical c_false = FALSE_;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__3 = 3;
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
static integer ierr;
static doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal d__[16] /* was [4][4] */;
static integer k;
static doublereal u[3], scale, x[4] /* was [2][2] */, dnorm;
static integer j2, j3, j4;
static doublereal xnorm, u1[3], u2[3];
extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_(
logical *, logical *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
static integer nd;
static doublereal cs, t11, t22;
extern doublereal dlamch_(char *);
static doublereal t33;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
static doublereal sn;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlarfx_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *);
static doublereal thresh, smlnum, wi1, wi2, wr1, wr2, eps, tau, tau1,
tau2;
#define d___ref(a_1,a_2) d__[(a_2)*4 + a_1 - 5]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3]
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
/* Swap two 1-by-1 blocks. */
t11 = t_ref(*j1, *j1);
t22 = t_ref(j2, j2);
/* Determine the transformation to perform the interchange. */
d__1 = t22 - t11;
dlartg_(&t_ref(*j1, j2), &d__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
drot_(&i__1, &t_ref(*j1, j3), ldt, &t_ref(j2, j3), ldt, &cs, &sn);
}
i__1 = *j1 - 1;
drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &sn);
t_ref(*j1, *j1) = t22;
t_ref(j2, j2) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &sn);
}
} else {
/* Swapping involves at least one 2-by-2 block.
Copy the diagonal block of order N1+N2 to the local array D
and compute its norm. */
nd = *n1 + *n2;
dlacpy_("Full", &nd, &nd, &t_ref(*j1, *j1), ldt, d__, &c__4);
dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting
swap. */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
/* Computing MAX */
d__1 = eps * 10. * dnorm;
thresh = max(d__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d___ref(*n1 +
1, *n1 + 1), &c__4, &d___ref(1, *n1 + 1), &c__4, &scale, x, &
c__2, &xnorm, &ierr);
/* Swap the adjacent diagonal blocks. */
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
}
L10:
/* N1 = 1, N2 = 2: generate elementary reflector H so that:
( scale, X11, X12 ) H = ( 0, 0, * ) */
u[0] = scale;
u[1] = x_ref(1, 1);
u[2] = x_ref(1, 2);
dlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t_ref(*j1, *j1);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(3, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(3,
3) - t11, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j2, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j3, j3) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L20:
/* N1 = 2, N2 = 1: generate elementary reflector H so that:
H ( -X11 ) = ( * )
( -X21 ) = ( 0 )
( scale ) = ( 0 ) */
u[0] = -x_ref(1, 1);
u[1] = -x_ref(2, 1);
u[2] = scale;
dlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t_ref(j3, j3);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(2, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 1)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(1,
1) - t33, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
dlarfx_("R", &j3, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, j2), ldt, &work[1]);
t_ref(*j1, *j1) = t33;
t_ref(j2, *j1) = 0.;
t_ref(j3, *j1) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L30:
/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
that:
H(2) H(1) ( -X11 -X12 ) = ( * * )
( -X21 -X22 ) ( 0 * )
( scale 0 ) ( 0 0 )
( 0 scale ) ( 0 0 ) */
u1[0] = -x_ref(1, 1);
u1[1] = -x_ref(2, 1);
u1[2] = scale;
dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
temp = -tau1 * (x_ref(1, 2) + u1[1] * x_ref(2, 2));
u2[0] = -temp * u1[1] - x_ref(2, 2);
u2[1] = -temp * u1[2];
u2[2] = scale;
dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("L", &c__3, &c__4, u2, &tau2, &d___ref(2, 1), &c__4, &work[1]);
dlarfx_("R", &c__4, &c__3, u2, &tau2, &d___ref(1, 2), &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__5 = (d__1 = d___ref(3, 1), abs(d__1)), d__6 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = d___ref(4,
1), abs(d__3)), d__5 = max(d__5,d__6), d__6 = (d__4 =
d___ref(4, 2), abs(d__4));
if (max(d__5,d__6) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u1, &tau1, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u1, &tau1, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u2, &tau2, &t_ref(j2, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u2, &tau2, &t_ref(1, j2), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j4, *j1) = 0.;
t_ref(j4, j2) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u1, &tau1, &q_ref(1, *j1), ldq, &work[1]);
dlarfx_("R", n, &c__3, u2, &tau2, &q_ref(1, j2), ldq, &work[1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
dlanv2_(&t_ref(*j1, *j1), &t_ref(*j1, j2), &t_ref(j2, *j1), &
t_ref(j2, j2), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
drot_(&i__1, &t_ref(*j1, *j1 + 2), ldt, &t_ref(j2, *j1 + 2), ldt,
&cs, &sn);
i__1 = *j1 - 1;
drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &
sn);
if (*wantq) {
drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &
sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
dlanv2_(&t_ref(j3, j3), &t_ref(j3, j4), &t_ref(j4, j3), &t_ref(j4,
j4), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
drot_(&i__1, &t_ref(j3, j3 + 2), ldt, &t_ref(j4, j3 + 2), ldt,
&cs, &sn);
}
i__1 = j3 - 1;
drot_(&i__1, &t_ref(1, j3), &c__1, &t_ref(1, j4), &c__1, &cs, &sn)
;
if (*wantq) {
drot_(n, &q_ref(1, j3), &c__1, &q_ref(1, j4), &c__1, &cs, &sn)
;
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of DLAEXC */
} /* dlaexc_ */
/* Subroutine */ int dlatm5_(integer *prtype, integer *m, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
c__, integer *ldc, doublereal *d__, integer *ldd, doublereal *e,
integer *lde, doublereal *f, integer *ldf, doublereal *r__, integer *
ldr, doublereal *l, integer *ldl, doublereal *alpha, integer *qblcka,
integer *qblckb)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
r_dim1, r_offset, i__1, i__2;
/* Builtin functions */
double sin(doublereal);
/* Local variables */
static integer i__, j, k;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal imeps, reeps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define d___ref(a_1,a_2) d__[(a_2)*d_dim1 + a_1]
#define e_ref(a_1,a_2) e[(a_2)*e_dim1 + a_1]
#define l_ref(a_1,a_2) l[(a_2)*l_dim1 + a_1]
#define r___ref(a_1,a_2) r__[(a_2)*r_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
June 30, 1999
Purpose
=======
DLATM5 generates matrices involved in the Generalized Sylvester
equation:
A * R - L * B = C
D * R - L * E = F
They also satisfy (the diagonalization condition)
[ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
[ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
Arguments
=========
PRTYPE (input) INTEGER
"Points" to a certian type of the matrices to generate
(see futher details).
M (input) INTEGER
Specifies the order of A and D and the number of rows in
C, F, R and L.
N (input) INTEGER
Specifies the order of B and E and the number of columns in
C, F, R and L.
A (output) DOUBLE PRECISION array, dimension (LDA, M).
On exit A M-by-M is initialized according to PRTYPE.
LDA (input) INTEGER
The leading dimension of A.
B (output) DOUBLE PRECISION array, dimension (LDB, N).
On exit B N-by-N is initialized according to PRTYPE.
LDB (input) INTEGER
The leading dimension of B.
C (output) DOUBLE PRECISION array, dimension (LDC, N).
On exit C M-by-N is initialized according to PRTYPE.
LDC (input) INTEGER
The leading dimension of C.
D (output) DOUBLE PRECISION array, dimension (LDD, M).
On exit D M-by-M is initialized according to PRTYPE.
LDD (input) INTEGER
The leading dimension of D.
E (output) DOUBLE PRECISION array, dimension (LDE, N).
On exit E N-by-N is initialized according to PRTYPE.
LDE (input) INTEGER
The leading dimension of E.
F (output) DOUBLE PRECISION array, dimension (LDF, N).
On exit F M-by-N is initialized according to PRTYPE.
LDF (input) INTEGER
The leading dimension of F.
R (output) DOUBLE PRECISION array, dimension (LDR, N).
On exit R M-by-N is initialized according to PRTYPE.
LDR (input) INTEGER
The leading dimension of R.
L (output) DOUBLE PRECISION array, dimension (LDL, N).
On exit L M-by-N is initialized according to PRTYPE.
LDL (input) INTEGER
The leading dimension of L.
ALPHA (input) DOUBLE PRECISION
Parameter used in generating PRTYPE = 1 and 5 matrices.
QBLCKA (input) INTEGER
When PRTYPE = 3, specifies the distance between 2-by-2
blocks on the diagonal in A. Otherwise, QBLCKA is not
referenced. QBLCKA > 1.
QBLCKB (input) INTEGER
When PRTYPE = 3, specifies the distance between 2-by-2
blocks on the diagonal in B. Otherwise, QBLCKB is not
referenced. QBLCKB > 1.
Further Details
===============
PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
A : if (i == j) then A(i, j) = 1.0
if (j == i + 1) then A(i, j) = -1.0
else A(i, j) = 0.0, i, j = 1...M
B : if (i == j) then B(i, j) = 1.0 - ALPHA
if (j == i + 1) then B(i, j) = 1.0
else B(i, j) = 0.0, i, j = 1...N
D : if (i == j) then D(i, j) = 1.0
else D(i, j) = 0.0, i, j = 1...M
E : if (i == j) then E(i, j) = 1.0
else E(i, j) = 0.0, i, j = 1...N
L = R are chosen from [-10...10],
which specifies the right hand sides (C, F).
PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
A : if (i <= j) then A(i, j) = [-1...1]
else A(i, j) = 0.0, i, j = 1...M
if (PRTYPE = 3) then
A(k + 1, k + 1) = A(k, k)
A(k + 1, k) = [-1...1]
sign(A(k, k + 1) = -(sin(A(k + 1, k))
k = 1, M - 1, QBLCKA
B : if (i <= j) then B(i, j) = [-1...1]
else B(i, j) = 0.0, i, j = 1...N
if (PRTYPE = 3) then
B(k + 1, k + 1) = B(k, k)
B(k + 1, k) = [-1...1]
sign(B(k, k + 1) = -(sign(B(k + 1, k))
k = 1, N - 1, QBLCKB
D : if (i <= j) then D(i, j) = [-1...1].
else D(i, j) = 0.0, i, j = 1...M
E : if (i <= j) then D(i, j) = [-1...1]
else E(i, j) = 0.0, i, j = 1...N
L, R are chosen from [-10...10],
which specifies the right hand sides (C, F).
PRTYPE = 4 Full
A(i, j) = [-10...10]
D(i, j) = [-1...1] i,j = 1...M
B(i, j) = [-10...10]
E(i, j) = [-1...1] i,j = 1...N
R(i, j) = [-10...10]
L(i, j) = [-1...1] i = 1..M ,j = 1...N
L, R specifies the right hand sides (C, F).
PRTYPE = 5 special case common and/or close eigs.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1 * 1;
f -= f_offset;
r_dim1 = *ldr;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
l_dim1 = *ldl;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
/* Function Body */
if (*prtype == 1) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
a_ref(i__, j) = 1.;
d___ref(i__, j) = 1.;
} else if (i__ == j - 1) {
a_ref(i__, j) = -1.;
d___ref(i__, j) = 0.;
} else {
a_ref(i__, j) = 0.;
d___ref(i__, j) = 0.;
}
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
b_ref(i__, j) = 1. - *alpha;
e_ref(i__, j) = 1.;
} else if (i__ == j - 1) {
b_ref(i__, j) = 1.;
e_ref(i__, j) = 0.;
} else {
b_ref(i__, j) = 0.;
e_ref(i__, j) = 0.;
}
/* L30: */
}
/* L40: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (i__ / j))) * 20.;
l_ref(i__, j) = r___ref(i__, j);
/* L50: */
}
/* L60: */
}
} else if (*prtype == 2 || *prtype == 3) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
if (i__ <= j) {
a_ref(i__, j) = (.5 - sin((doublereal) i__)) * 2.;
d___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.;
} else {
a_ref(i__, j) = 0.;
d___ref(i__, j) = 0.;
}
/* L70: */
}
/* L80: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (i__ <= j) {
b_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 2.;
e_ref(i__, j) = (.5 - sin((doublereal) j)) * 2.;
} else {
b_ref(i__, j) = 0.;
e_ref(i__, j) = 0.;
}
/* L90: */
}
/* L100: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 20.;
l_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 20.;
/* L110: */
}
/* L120: */
}
if (*prtype == 3) {
if (*qblcka <= 1) {
*qblcka = 2;
}
i__1 = *m - 1;
i__2 = *qblcka;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
a_ref(k + 1, k + 1) = a_ref(k, k);
a_ref(k + 1, k) = -sin(a_ref(k, k + 1));
/* L130: */
}
if (*qblckb <= 1) {
*qblckb = 2;
}
i__2 = *n - 1;
i__1 = *qblckb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
b_ref(k + 1, k + 1) = b_ref(k, k);
b_ref(k + 1, k) = -sin(b_ref(k, k + 1));
/* L140: */
}
}
} else if (*prtype == 4) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
a_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 20.;
d___ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 2.;
/* L150: */
}
/* L160: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
b_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 20.;
e_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.;
/* L170: */
}
/* L180: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (j / i__))) * 20.;
l_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.;
/* L190: */
}
/* L200: */
}
} else if (*prtype >= 5) {
reeps = 20. / *alpha;
imeps = -1.5 / *alpha;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * *alpha
/ 20.;
l_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * *alpha /
20.;
/* L210: */
}
/* L220: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
d___ref(i__, i__) = 1.;
/* L230: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ <= 4) {
a_ref(i__, i__) = 1.;
if (i__ > 2) {
a_ref(i__, i__) = reeps + 1.;
}
if (i__ % 2 != 0 && i__ < *m) {
a_ref(i__, i__ + 1) = imeps;
} else if (i__ > 1) {
a_ref(i__, i__ - 1) = -imeps;
}
} else if (i__ <= 8) {
if (i__ <= 6) {
a_ref(i__, i__) = reeps;
} else {
a_ref(i__, i__) = -reeps;
}
if (i__ % 2 != 0 && i__ < *m) {
a_ref(i__, i__ + 1) = 1.;
} else if (i__ > 1) {
a_ref(i__, i__ - 1) = -1.;
}
} else {
a_ref(i__, i__) = 1.;
if (i__ % 2 != 0 && i__ < *m) {
a_ref(i__, i__ + 1) = imeps * 2;
} else if (i__ > 1) {
a_ref(i__, i__ - 1) = -imeps * 2;
}
}
/* L240: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
e_ref(i__, i__) = 1.;
if (i__ <= 4) {
b_ref(i__, i__) = -1.;
if (i__ > 2) {
b_ref(i__, i__) = 1. - reeps;
}
if (i__ % 2 != 0 && i__ < *n) {
b_ref(i__, i__ + 1) = imeps;
} else if (i__ > 1) {
b_ref(i__, i__ - 1) = -imeps;
}
} else if (i__ <= 8) {
if (i__ <= 6) {
b_ref(i__, i__) = reeps;
} else {
b_ref(i__, i__) = -reeps;
}
if (i__ % 2 != 0 && i__ < *n) {
b_ref(i__, i__ + 1) = imeps + 1.;
} else if (i__ > 1) {
b_ref(i__, i__ - 1) = -1. - imeps;
}
} else {
b_ref(i__, i__) = 1. - reeps;
if (i__ % 2 != 0 && i__ < *n) {
b_ref(i__, i__ + 1) = imeps * 2;
} else if (i__ > 1) {
b_ref(i__, i__ - 1) = -imeps * 2;
}
}
/* L250: */
}
}
/* Compute rhs (C, F) */
dgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr,
&c_b30, &c__[c_offset], ldc);
dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, &
c_b29, &c__[c_offset], ldc);
dgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset],
ldr, &c_b30, &f[f_offset], ldf);
dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, &
c_b29, &f[f_offset], ldf);
/* End of DLATM5 */
return 0;
} /* dlatm5_ */
/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
complex *f, integer *ldf, real *scale, real *dif, complex *work,
integer *lwork, integer *iwork, integer *info)
{
/* -- LAPACK 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
=======
CTGSYL solves the generalized Sylvester equation:
A * R - L * B = scale * C (1)
D * R - L * E = scale * F
where R and L are unknown m-by-n matrices, (A, D), (B, E) and
(C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
respectively, with complex entries. A, B, D and E are upper
triangular (i.e., (A,D) and (B,E) in generalized Schur form).
The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
is an output scaling factor chosen to avoid overflow.
In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
is defined as
Z = [ kron(In, A) -kron(B', Im) ] (2)
[ kron(In, D) -kron(E', Im) ],
Here Ix is the identity matrix of size x and X' is the conjugate
transpose of X. Kron(X, Y) is the Kronecker product between the
matrices X and Y.
If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b
is solved for, which is equivalent to solve for R and L in
A' * R + D' * L = scale * C (3)
R * B' + L * E' = scale * -F
This case (TRANS = 'C') is used to compute an one-norm-based estimate
of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
and (B,E), using CLACON.
If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of
Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
reciprocal of the smallest singular value of Z.
This is a level-3 BLAS algorithm.
Arguments
=========
TRANS (input) CHARACTER*1
= 'N': solve the generalized sylvester equation (1).
= 'C': solve the "conjugate transposed" system (3).
IJOB (input) INTEGER
Specifies what kind of functionality to be performed.
=0: solve (1) only.
=1: The functionality of 0 and 3.
=2: The functionality of 0 and 4.
=3: Only an estimate of Dif[(A,D), (B,E)] is computed.
(look ahead strategy is used).
=4: Only an estimate of Dif[(A,D), (B,E)] is computed.
(CGECON on sub-systems is used).
Not referenced if TRANS = 'C'.
M (input) INTEGER
The order of the matrices A and D, and the row dimension of
the matrices C, F, R and L.
N (input) INTEGER
The order of the matrices B and E, and the column dimension
of the matrices C, F, R and L.
A (input) COMPLEX array, dimension (LDA, M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1, M).
B (input) COMPLEX array, dimension (LDB, N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1, N).
C (input/output) COMPLEX array, dimension (LDC, N)
On entry, C contains the right-hand-side of the first matrix
equation in (1) or (3).
On exit, if IJOB = 0, 1 or 2, C has been overwritten by
the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
the solution achieved during the computation of the
Dif-estimate.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1, M).
D (input) COMPLEX array, dimension (LDD, M)
The upper triangular matrix D.
LDD (input) INTEGER
The leading dimension of the array D. LDD >= max(1, M).
E (input) COMPLEX array, dimension (LDE, N)
The upper triangular matrix E.
LDE (input) INTEGER
The leading dimension of the array E. LDE >= max(1, N).
F (input/output) COMPLEX array, dimension (LDF, N)
On entry, F contains the right-hand-side of the second matrix
equation in (1) or (3).
On exit, if IJOB = 0, 1 or 2, F has been overwritten by
the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
the solution achieved during the computation of the
Dif-estimate.
LDF (input) INTEGER
The leading dimension of the array F. LDF >= max(1, M).
DIF (output) REAL
On exit DIF is the reciprocal of a lower bound of the
reciprocal of the Dif-function, i.e. DIF is an upper bound of
Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
SCALE (output) REAL
On exit SCALE is the scaling factor in (1) or (3).
If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
to a slightly perturbed system but the input matrices A, B,
D and E have not been changed. If SCALE = 0, R and L will
hold the solutions to the homogenious system with C = F = 0.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
IF IJOB = 0, WORK is not referenced. Otherwise,
LWORK (input) INTEGER
The dimension of the array WORK. LWORK > = 1.
If IJOB = 1 or 2 and TRANS = 'N', LWORK >= 2*M*N.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) INTEGER array, dimension (M+N+2)
If IJOB = 0, IWORK is not referenced.
INFO (output) INTEGER
=0: successful exit
<0: If INFO = -i, the i-th argument had an illegal value.
>0: (A, D) and (B, E) have common or very close
eigenvalues.
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
[1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK Working
Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
No 1, 1996.
[2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
Appl., 15(4):1045-1060, 1994.
[3] B. Kagstrom and L. Westin, Generalized Schur Methods with
Condition Estimators for Solving the Generalized Sylvester
Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
July 1989, pp 745-751.
=====================================================================
Decode and test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c_n1 = -1;
static integer c__5 = 5;
static integer c__0 = 0;
static integer c__1 = 1;
static complex c_b16 = {0.f,0.f};
static complex c_b53 = {-1.f,0.f};
static complex c_b54 = {1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
i__4;
complex q__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real dsum;
static integer i__, j, k, p, q;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemm_(char *, char *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *);
extern logical lsame_(char *, char *);
static integer ifunc, linfo;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer lwmin;
static real scale2;
extern /* Subroutine */ int ctgsy2_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, real *, integer *);
static integer ie, je, mb, nb;
static real dscale;
static integer is, js, pq;
static real scaloc;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer iround;
static logical notran;
static integer isolve;
static logical lquery;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define d___subscr(a_1,a_2) (a_2)*d_dim1 + a_1
#define d___ref(a_1,a_2) d__[d___subscr(a_1,a_2)]
#define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define f_subscr(a_1,a_2) (a_2)*f_dim1 + a_1
#define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1 * 1;
f -= f_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
lquery = *lwork == -1;
if ((*ijob == 1 || *ijob == 2) && notran) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * *n;
lwmin = max(i__1,i__2);
} else {
lwmin = 1;
}
if (! notran && ! lsame_(trans, "C")) {
*info = -1;
} else if (*ijob < 0 || *ijob > 4) {
*info = -2;
} else if (*m <= 0) {
*info = -3;
} else if (*n <= 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*ldd < max(1,*m)) {
*info = -12;
} else if (*lde < max(1,*n)) {
*info = -14;
} else if (*ldf < max(1,*m)) {
*info = -16;
} else if (*lwork < lwmin && ! lquery) {
*info = -20;
}
if (*info == 0) {
work[1].r = (real) lwmin, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSYL", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Determine optimal block sizes MB and NB */
mb = ilaenv_(&c__2, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = ilaenv_(&c__5, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
isolve = 1;
ifunc = 0;
if (*ijob >= 3 && notran) {
ifunc = *ijob - 2;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L10: */
}
} else if (*ijob >= 1 && notran) {
isolve = 2;
}
if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
/* Use unblocked Level 2 solver */
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
*scale = 1.f;
dscale = 0.f;
dsum = 1.f;
pq = *m * *n;
ctgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
&c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
lde, &f[f_offset], ldf, scale, &dsum, &dscale, info);
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
ifunc = *ijob;
scale2 = *scale;
clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L20: */
}
} else if (isolve == 2 && iround == 2) {
clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
/* L30: */
}
return 0;
}
/* Determine block structure of A */
p = 0;
i__ = 1;
L40:
if (i__ > *m) {
goto L50;
}
++p;
iwork[p] = i__;
i__ += mb;
if (i__ >= *m) {
goto L50;
}
goto L40;
L50:
iwork[p + 1] = *m + 1;
if (iwork[p] == iwork[p + 1]) {
--p;
}
/* Determine block structure of B */
q = p + 1;
j = 1;
L60:
if (j > *n) {
goto L70;
}
++q;
iwork[q] = j;
j += nb;
if (j >= *n) {
goto L70;
}
goto L60;
L70:
iwork[q + 1] = *n + 1;
if (iwork[q] == iwork[q + 1]) {
--q;
}
if (notran) {
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
/* Solve (I, J) - subsystem
A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
pq = 0;
*scale = 1.f;
dscale = 0.f;
dsum = 1.f;
i__2 = q;
for (j = p + 2; j <= i__2; ++j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
for (i__ = p; i__ >= 1; --i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &
b_ref(js, js), ldb, &c___ref(is, js), ldc, &
d___ref(is, is), ldd, &e_ref(js, js), lde, &f_ref(
is, js), ldf, &scaloc, &dsum, &dscale, &linfo);
if (linfo > 0) {
*info = linfo;
}
pq += mb * nb;
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L80: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(1, k), &c__1);
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(1, k), &c__1);
/* L90: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1);
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1);
/* L100: */
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L110: */
}
*scale *= scaloc;
}
/* Substitute R(I,J) and L(I,J) into remaining equation. */
if (i__ > 1) {
i__3 = is - 1;
cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &a_ref(1,
is), lda, &c___ref(is, js), ldc, &c_b54, &
c___ref(1, js), ldc);
i__3 = is - 1;
cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &d___ref(1,
is), ldd, &c___ref(is, js), ldc, &c_b54, &
f_ref(1, js), ldf);
}
if (j < q) {
i__3 = *n - je;
cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is,
js), ldf, &b_ref(js, je + 1), ldb, &c_b54, &
c___ref(is, je + 1), ldc);
i__3 = *n - je;
cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is,
js), ldf, &e_ref(js, je + 1), lde, &c_b54, &
f_ref(is, je + 1), ldf);
}
/* L120: */
}
/* L130: */
}
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
ifunc = *ijob;
scale2 = *scale;
clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L140: */
}
} else if (isolve == 2 && iround == 2) {
clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
/* L150: */
}
} else {
/* Solve transposed (I, J)-subsystem
A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
for I = 1,2,..., P; J = Q, Q-1,..., 1 */
*scale = 1.f;
i__1 = p;
for (i__ = 1; i__ <= i__1; ++i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
i__2 = p + 2;
for (j = q; j >= i__2; --j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &b_ref(
js, js), ldb, &c___ref(is, js), ldc, &d___ref(is, is),
ldd, &e_ref(js, js), lde, &f_ref(is, js), ldf, &
scaloc, &dsum, &dscale, &linfo);
if (linfo > 0) {
*info = linfo;
}
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L160: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(1, k), &c__1);
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(1, k), &c__1);
/* L170: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1);
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1);
/* L180: */
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L190: */
}
*scale *= scaloc;
}
/* Substitute R(I,J) and L(I,J) into remaining equation. */
if (j > p + 2) {
i__3 = js - 1;
cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &c___ref(is, js)
, ldc, &b_ref(1, js), ldb, &c_b54, &f_ref(is, 1),
ldf);
i__3 = js - 1;
cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &f_ref(is, js),
ldf, &e_ref(1, js), lde, &c_b54, &f_ref(is, 1),
ldf);
}
if (i__ < p) {
i__3 = *m - ie;
cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &a_ref(is, ie +
1), lda, &c___ref(is, js), ldc, &c_b54, &c___ref(
ie + 1, js), ldc);
i__3 = *m - ie;
cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &d___ref(is, ie
+ 1), ldd, &f_ref(is, js), ldf, &c_b54, &c___ref(
ie + 1, js), ldc);
}
/* L200: */
}
/* L210: */
}
}
work[1].r = (real) lwmin, work[1].i = 0.f;
return 0;
/* End of CTGSYL */
} /* ctgsyl_ */
/* Subroutine */ int dlakf2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *b, doublereal *d__, doublereal *e, doublereal *z__,
integer *ldz)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1,
e_offset, z_dim1, z_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j, l, ik, jk, mn;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
static integer mn2;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define d___ref(a_1,a_2) d__[(a_2)*d_dim1 + a_1]
#define e_ref(a_1,a_2) e[(a_2)*e_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_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
June 30, 1999
Purpose
=======
Form the 2*M*N by 2*M*N matrix
Z = [ kron(In, A) -kron(B', Im) ]
[ kron(In, D) -kron(E', Im) ],
where In is the identity matrix of size n and X' is the transpose
of X. kron(X, Y) is the Kronecker product between the matrices X
and Y.
Arguments
=========
M (input) INTEGER
Size of matrix, must be >= 1.
N (input) INTEGER
Size of matrix, must be >= 1.
A (input) DOUBLE PRECISION, dimension ( LDA, M )
The matrix A in the output matrix Z.
LDA (input) INTEGER
The leading dimension of A, B, D, and E. ( LDA >= M+N )
B (input) DOUBLE PRECISION, dimension ( LDA, N )
D (input) DOUBLE PRECISION, dimension ( LDA, M )
E (input) DOUBLE PRECISION, dimension ( LDA, N )
The matrices used in forming the output matrix Z.
Z (output) DOUBLE PRECISION, dimension ( LDZ, 2*M*N )
The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
LDZ (input) INTEGER
The leading dimension of Z. ( LDZ >= 2*M*N )
====================================================================
Initialize Z
Parameter adjustments */
e_dim1 = *lda;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
d_dim1 = *lda;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
/* Function Body */
mn = *m * *n;
mn2 = mn << 1;
dlaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz);
ik = 1;
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
/* form kron(In, A) */
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = *m;
for (j = 1; j <= i__3; ++j) {
z___ref(ik + i__ - 1, ik + j - 1) = a_ref(i__, j);
/* L10: */
}
/* L20: */
}
/* form kron(In, D) */
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = *m;
for (j = 1; j <= i__3; ++j) {
z___ref(ik + mn + i__ - 1, ik + j - 1) = d___ref(i__, j);
/* L30: */
}
/* L40: */
}
ik += *m;
/* L50: */
}
ik = 1;
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
jk = mn + 1;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* form -kron(B', Im) */
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(ik + i__ - 1, jk + i__ - 1) = -b_ref(j, l);
/* L60: */
}
/* form -kron(E', Im) */
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(ik + mn + i__ - 1, jk + i__ - 1) = -e_ref(j, l);
/* L70: */
}
jk += *m;
/* L80: */
}
ik += *m;
/* L90: */
}
return 0;
/* End of DLAKF2 */
} /* dlakf2_ */
/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n,
doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal
*scale, doublereal *x, doublereal *work, integer *info)
{
/* -- LAPACK auxiliary 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
=======
DLAQTR solves the real quasi-triangular system
op(T)*p = scale*c, if LREAL = .TRUE.
or the complex quasi-triangular systems
op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.
in real arithmetic, where T is upper quasi-triangular.
If LREAL = .FALSE., then the first diagonal block of T must be
1 by 1, B is the specially structured matrix
B = [ b(1) b(2) ... b(n) ]
[ w ]
[ w ]
[ . ]
[ w ]
op(A) = A or A', A' denotes the conjugate transpose of
matrix A.
On input, X = [ c ]. On output, X = [ p ].
[ d ] [ q ]
This subroutine is designed for the condition number estimation
in routine DTRSNA.
Arguments
=========
LTRAN (input) LOGICAL
On entry, LTRAN specifies the option of conjugate transpose:
= .FALSE., op(T+i*B) = T+i*B,
= .TRUE., op(T+i*B) = (T+i*B)'.
LREAL (input) LOGICAL
On entry, LREAL specifies the input matrix structure:
= .FALSE., the input is complex
= .TRUE., the input is real
N (input) INTEGER
On entry, N specifies the order of T+i*B. N >= 0.
T (input) DOUBLE PRECISION array, dimension (LDT,N)
On entry, T contains a matrix in Schur canonical form.
If LREAL = .FALSE., then the first diagonal block of T mu
be 1 by 1.
LDT (input) INTEGER
The leading dimension of the matrix T. LDT >= max(1,N).
B (input) DOUBLE PRECISION array, dimension (N)
On entry, B contains the elements to form the matrix
B as described above.
If LREAL = .TRUE., B is not referenced.
W (input) DOUBLE PRECISION
On entry, W is the diagonal element of the matrix B.
If LREAL = .TRUE., W is not referenced.
SCALE (output) DOUBLE PRECISION
On exit, SCALE is the scale factor.
X (input/output) DOUBLE PRECISION array, dimension (2*N)
On entry, X contains the right hand side of the system.
On exit, X is overwritten by the solution.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
On exit, INFO is set to
0: successful exit.
1: the some diagonal 1 by 1 block has been perturbed by
a small number SMIN to keep nonsingularity.
2: the some diagonal 2 by 2 block has been perturbed by
a small number in DLALN2 to keep nonsingularity.
NOTE: In the interests of speed, this routine does not
check the inputs for errors.
=====================================================================
Do not test the input parameters for errors
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static logical c_false = FALSE_;
static integer c__2 = 2;
static doublereal c_b21 = 1.;
static doublereal c_b25 = 0.;
static logical c_true = TRUE_;
/* System generated locals */
integer t_dim1, t_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer ierr;
static doublereal smin, xmax, d__[4] /* was [2][2] */;
static integer i__, j, k;
static doublereal v[4] /* was [2][2] */, z__;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer jnext, j1, j2;
static doublereal sminw;
static integer n1, n2;
static doublereal xnorm;
extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
, doublereal *, integer *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static doublereal si, xj;
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal scaloc, sr;
extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal bignum;
static logical notran;
static doublereal smlnum, rec, eps, tjj, tmp;
#define d___ref(a_1,a_2) d__[(a_2)*2 + a_1 - 3]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define v_ref(a_1,a_2) v[(a_2)*2 + a_1 - 3]
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
--b;
--x;
--work;
/* Function Body */
notran = ! (*ltran);
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__);
if (! (*lreal)) {
/* Computing MAX */
d__1 = xnorm, d__2 = abs(*w), d__1 = max(d__1,d__2), d__2 = dlange_(
"M", n, &c__1, &b[1], n, d__);
xnorm = max(d__1,d__2);
}
/* Computing MAX */
d__1 = smlnum, d__2 = eps * xnorm;
smin = max(d__1,d__2);
/* Compute 1-norm of each column of strictly upper triangular
part of T to control overflow in triangular solver. */
work[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
work[j] = dasum_(&i__2, &t_ref(1, j), &c__1);
/* L10: */
}
if (! (*lreal)) {
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
work[i__] += (d__1 = b[i__], abs(d__1));
/* L20: */
}
}
n2 = *n << 1;
n1 = *n;
if (! (*lreal)) {
n1 = n2;
}
k = idamax_(&n1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
*scale = 1.;
if (xmax > bignum) {
*scale = bignum / xmax;
dscal_(&n1, scale, &x[1], &c__1);
xmax = bignum;
}
if (*lreal) {
if (notran) {
/* Solve T*p = scale*c */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L30;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t_ref(j, j - 1) != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* Meet 1 by 1 diagonal block
Scale to avoid overflow when computing
x(j) = b(j)/T(j,j) */
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t_ref(j1, j1), abs(d__1));
tmp = t_ref(j1, j1);
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (xj == 0.) {
goto L30;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
xj = (d__1 = x[j1], abs(d__1));
/* Scale x if necessary to avoid overflow when adding a
multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], &
c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
} else {
/* Meet 2 by 2 diagonal block
Call 2 by 2 linear system solve, to take
care of possible overflow by scaling factor. */
d___ref(1, 1) = x[j1];
d___ref(2, 1) = x[j2];
dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t_ref(j1,
j1), ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, &
c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v_ref(1, 1);
x[j2] = v_ref(2, 1);
/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
to avoid overflow in updating right-hand side.
Computing MAX */
d__3 = (d__1 = v_ref(1, 1), abs(d__1)), d__4 = (d__2 =
v_ref(2, 1), abs(d__2));
xj = max(d__3,d__4);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update right-hand side */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], &
c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t_ref(1, j2), &c__1, &x[1], &
c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
}
L30:
;
}
} else {
/* Solve T'*p = scale*c */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L40;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t_ref(j + 1, j) != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block
Scale if necessary to avoid overflow in forming the
right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t_ref(1, j1), &c__1, &x[1], &c__1);
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t_ref(j1, j1), abs(d__1));
tmp = t_ref(j1, j1);
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
/* Computing MAX */
d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1));
xmax = max(d__2,d__3);
} else {
/* 2 by 2 diagonal block
Scale if necessary to avoid overflow in forming the
right-hand side elements by inner product.
Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2));
xj = max(d__3,d__4);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j2], d__2 = work[j1];
if (max(d__1,d__2) > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d___ref(1, 1) = x[j1] - ddot_(&i__2, &t_ref(1, j1), &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d___ref(2, 1) = x[j2] - ddot_(&i__2, &t_ref(1, j2), &c__1,
&x[1], &c__1);
dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t_ref(j1,
j1), ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, &
c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v_ref(1, 1);
x[j2] = v_ref(2, 1);
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2)), d__3 = max(d__3,d__4);
xmax = max(d__3,xmax);
}
L40:
;
}
}
} else {
/* Computing MAX */
d__1 = eps * abs(*w);
sminw = max(d__1,smin);
if (notran) {
/* Solve (T + iB)*(p+iq) = c+id */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L70;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t_ref(j, j - 1) != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block
Scale if necessary to avoid overflow in division */
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
tjj = (d__1 = t_ref(j1, j1), abs(d__1)) + abs(z__);
tmp = t_ref(j1, j1);
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (xj == 0.) {
goto L70;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si);
x[j1] = sr;
x[*n + j1] = si;
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
/* Scale x if necessary to avoid overflow when adding a
multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], &
c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[*n + 1],
&c__1);
x[1] += b[j1] * x[*n + j1];
x[*n + 1] -= b[j1] * x[j1];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + (
d__2 = x[k + *n], abs(d__2));
xmax = max(d__3,d__4);
/* L50: */
}
}
} else {
/* Meet 2 by 2 diagonal block */
d___ref(1, 1) = x[j1];
d___ref(2, 1) = x[j2];
d___ref(1, 2) = x[*n + j1];
d___ref(2, 2) = x[*n + j2];
d__1 = -(*w);
dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t_ref(j1,
j1), ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, &
d__1, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
i__1 = *n << 1;
dscal_(&i__1, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v_ref(1, 1);
x[j2] = v_ref(2, 1);
x[*n + j1] = v_ref(1, 2);
x[*n + j2] = v_ref(2, 2);
/* Scale X(J1), .... to avoid overflow in
updating right hand side.
Computing MAX */
d__5 = (d__1 = v_ref(1, 1), abs(d__1)) + (d__2 = v_ref(1,
2), abs(d__2)), d__6 = (d__3 = v_ref(2, 1), abs(
d__3)) + (d__4 = v_ref(2, 2), abs(d__4));
xj = max(d__5,d__6);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update the right-hand side. */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], &
c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t_ref(1, j2), &c__1, &x[1], &
c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[*n + 1],
&c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j2];
daxpy_(&i__1, &d__1, &t_ref(1, j2), &c__1, &x[*n + 1],
&c__1);
x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2];
x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + *
n], abs(d__2));
xmax = max(d__3,xmax);
/* L60: */
}
}
}
L70:
;
}
} else {
/* Solve (T + iB)'*(p+iq) = c+id */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L80;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t_ref(j + 1, j) != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block
Scale if necessary to avoid overflow in forming the
right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t_ref(1, j1), &c__1, &x[1], &c__1);
i__2 = j1 - 1;
x[*n + j1] -= ddot_(&i__2, &t_ref(1, j1), &c__1, &x[*n +
1], &c__1);
if (j1 > 1) {
x[j1] -= b[j1] * x[*n + 1];
x[*n + j1] += b[j1] * x[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
/* Scale if necessary to avoid overflow in
complex division */
tjj = (d__1 = t_ref(j1, j1), abs(d__1)) + abs(z__);
tmp = t_ref(j1, j1);
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
d__1 = -z__;
dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si);
x[j1] = sr;
x[j1 + *n] = si;
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n],
abs(d__2));
xmax = max(d__3,xmax);
} else {
/* 2 by 2 diagonal block
Scale if necessary to avoid overflow in forming the
right-hand side element by inner product.
Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4));
xj = max(d__5,d__6);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xj) / xmax) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d___ref(1, 1) = x[j1] - ddot_(&i__2, &t_ref(1, j1), &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d___ref(2, 1) = x[j2] - ddot_(&i__2, &t_ref(1, j2), &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d___ref(1, 2) = x[*n + j1] - ddot_(&i__2, &t_ref(1, j1), &
c__1, &x[*n + 1], &c__1);
i__2 = j1 - 1;
d___ref(2, 2) = x[*n + j2] - ddot_(&i__2, &t_ref(1, j2), &
c__1, &x[*n + 1], &c__1);
d___ref(1, 1) = d___ref(1, 1) - b[j1] * x[*n + 1];
d___ref(2, 1) = d___ref(2, 1) - b[j2] * x[*n + 1];
d___ref(1, 2) = d___ref(1, 2) + b[j1] * x[1];
d___ref(2, 2) = d___ref(2, 2) + b[j2] * x[1];
dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t_ref(j1,
j1), ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, w,
v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(&n2, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v_ref(1, 1);
x[j2] = v_ref(2, 1);
x[*n + j1] = v_ref(1, 2);
x[*n + j2] = v_ref(2, 2);
/* Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4)), d__5 = max(d__5,
d__6);
xmax = max(d__5,xmax);
}
L80:
;
}
}
}
return 0;
/* End of DLAQTR */
} /* dlaqtr_ */
/* Main program */ MAIN__(void)
{
/* Initialized data */
static integer iseed[4] = { 0,0,0,1 };
static integer mxtype[4] = { 8,4,5,4 };
/* Format strings */
static char fmt_9993[] = "(\002 Timing the Nonsymmetric Eigenvalue Probl"
"em routines\002,/\002 DGEHRD, DHSEQR, DTREVC, and DHSEIN\002)";
static char fmt_9992[] = "(\002 Timing the Symmetric Eigenvalue Problem "
"routines\002,/\002 DSYTRD, DSTEQR, and DSTERF\002)";
static char fmt_9991[] = "(\002 Timing the Singular Value Decomposition "
"routines\002,/\002 DGEBRD, DBDSQR, DORGBR, DBDSDC and DGESD"
"D\002)";
static char fmt_9990[] = "(\002 Timing the Generalized Eigenvalue Proble"
"m routines\002,/\002 DGGHRD, DHGEQZ, and DTGEVC \002)";
static char fmt_9996[] = "(1x,a3,\002: Unrecognized path name\002)";
static char fmt_9985[] = "(/\002 LAPACK VERSION 3.0, released June 30, 1"
"999 \002)";
static char fmt_9989[] = "(/\002 The following parameter values will be "
"used:\002)";
static char fmt_9995[] = "(\002 *** Invalid input value: \002,a6,\002"
"=\002,i6,\002; must be >=\002,i6)";
static char fmt_9994[] = "(\002 *** Invalid input value: \002,a6,\002"
"=\002,i6,\002; must be <=\002,i6)";
static char fmt_9988[] = "(\002 Values of \002,a5,\002: \002,10i6,/1"
"9x,10i6)";
static char fmt_9987[] = "(/\002 Minimum time a subroutine will be timed"
" = \002,f8.2,\002 seconds\002,/)";
static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
"rors\002)";
static char fmt_9986[] = "(\002 *** Error code from \002,a6,\002 = \002,"
"i4)";
static char fmt_9998[] = "(//\002 End of timing run\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;
/* Builtin functions */
integer 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);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static char line[80];
static integer info;
static char path[3];
static integer mval[12], nval[12];
static doublereal work[649241], a[1008000] /* was [168000][6] */, d__[
1600] /* was [400][4] */;
static integer i__;
static logical fatal;
extern /* Subroutine */ int dtim21_(char *, integer *, integer *, integer
*, logical *, integer *, integer *, integer *, integer *, integer
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, logical *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, integer *, ftnlen),
dtim22_(char *, integer *, integer *, integer *, logical *,
integer *, integer *, integer *, doublereal *, integer *, integer
*, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, logical *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, integer *, ftnlen);
static integer nbval[10];
extern /* Subroutine */ int dtim51_(char *, integer *, integer *, integer
*, logical *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
logical *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, integer *, ftnlen),
dtim26_(char *, integer *, integer *, integer *, integer *,
logical *, integer *, integer *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, logical *,
doublereal *, integer *, integer *, integer *, doublereal *,
integer *, integer *, integer *, integer *, ftnlen);
static char vname[6];
static integer nsval[10];
static char c3[3];
static integer iwork[10];
static doublereal s1, s2;
static integer iwork2[20406], nn;
extern doublereal dsecnd_(void);
static integer ldaval[10], nbkval[10], nbmval[10];
extern logical lsamen_(integer *, char *, char *);
static integer mxbval[10];
static doublereal timmin;
static integer nparms;
static logical dotype[10], logwrk[400];
static doublereal opcnts[30000] /* was [10][10][12][25] */, result[
30000] /* was [10][10][12][25] */;
static integer maxtyp, ntypes;
static logical gep, nep, sep, svd;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 5, 1, "(A3)", 0 };
static cilist io___11 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___12 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___13 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___16 = { 0, 6, 0, fmt_9985, 0 };
static cilist io___17 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___18 = { 0, 5, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___21 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___27 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___28 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___29 = { 0, 5, 0, 0, 0 };
static cilist io___31 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___32 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___33 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___34 = { 0, 5, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___37 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___38 = { 0, 5, 0, 0, 0 };
static cilist io___40 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___41 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___42 = { 0, 5, 0, 0, 0 };
static cilist io___44 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___46 = { 0, 5, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___49 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___50 = { 0, 5, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___53 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___54 = { 0, 5, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___58 = { 0, 5, 0, 0, 0 };
static cilist io___60 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___61 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___62 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___63 = { 0, 5, 0, 0, 0 };
static cilist io___65 = { 0, 6, 0, fmt_9987, 0 };
static cilist io___66 = { 0, 5, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___70 = { 0, 5, 0, 0, 0 };
static cilist io___73 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___74 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___75 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___76 = { 0, 5, 1, "(A80)", 0 };
static cilist io___87 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___88 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___89 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___90 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___91 = { 0, 6, 0, 0, 0 };
static cilist io___92 = { 0, 6, 0, 0, 0 };
static cilist io___93 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___94 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___96 = { 0, 6, 0, fmt_9997, 0 };
#define a_ref(a_1,a_2) a[(a_2)*168000 + a_1 - 168001]
#define d___ref(a_1,a_2) d__[(a_2)*400 + a_1 - 401]
/* -- 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
=======
DTIMEE is the main timing program for the DOUBLE PRECISION matrix
eigenvalue routines in LAPACK.
There are four sets of routines that can be timed:
NEP (Nonsymmetric Eigenvalue Problem):
Includes DGEHRD, DHSEQR, DTREVC, and DHSEIN
SEP (Symmetric Eigenvalue Problem):
Includes DSYTRD, DORGTR, DORMTR, DSTEQR, DSTERF, DPTEQR, DSTEBZ,
DSTEIN, and DSTEDC
SVD (Singular Value Decomposition):
Includes DGEBRD, DBDSQR, DORGBR, DBDSDC and DGESDD
GEP (Generalized nonsymmetric Eigenvalue Problem):
Includes DGGHRD, DHGEQZ, and DTGEVC
Each test path has a different input file. The first line of the
input file should contain the characters NEP, SEP, SVD, or GEP in
columns 1-3. The number of remaining lines depends on what is found
on the first line.
-----------------------------------------------------------------------
NEP input file:
line 2: NN, INTEGER
Number of values of N.
line 3: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 4: NPARM, INTEGER
Number of values of the parameters NB, NS, MAXB, and LDA.
line 5: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 6: NSVAL, INTEGER array, dimension (NPARM)
The values for the number of shifts.
line 7: MXBVAL, INTEGER array, dimension (NPARM)
The values for MAXB, used in determining whether multishift
will be used.
line 8: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 9: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 10: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 11 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed. For the nonsymmetric eigenvalue problem, the path name is
'DHS'. A line to request all the routines in this path has the form
DHS T T T T T T T T T T T T
where the first 3 characters specify the path name, and up to MAXTYP
nonblank characters may appear in columns 4-80. If the k-th such
character is 'T' or 't', the k-th routine will be timed. If at least
one but fewer than 12 nonblank characters are specified, the
remaining routines will not be timed. If columns 4-80 are blank, all
the routines will be timed, so the input line
DHS
is equivalent to the line above.
-----------------------------------------------------------------------
SEP input file:
line 2: NN, INTEGER
Number of values of N.
line 3: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 4: NPARM, INTEGER
Number of values of the parameters NB and LDA.
line 5: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 6: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 7: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 8: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 9 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed as for the NEP input file. For the symmetric eigenvalue
problem, the path name is 'DST' and up to 8 routines may be timed.
-----------------------------------------------------------------------
SVD input file:
line 2: NN, INTEGER
Number of values of M and N.
line 3: MVAL, INTEGER array, dimension (NN)
The values for the matrix dimension M.
line 4: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 5: NPARM, INTEGER
Number of values of the parameters NB and LDA.
line 6: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 7: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 8: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 9: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 10 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed as for the NEP input file. For the singular value
decomposition the path name is 'DBD' and up to 16 routines may be
timed.
-----------------------------------------------------------------------
GEP input file:
line 2: NN, INTEGER
Number of values of N.
line 3: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 4: NPARM, INTEGER
Number of values of the parameters NB, NS, MAXB, and LDA.
line 5: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 6: NSVAL, INTEGER array, dimension (NPARM)
The values for the number of shifts.
line 7: NEIVAL, INTEGER array, dimension (NPARM)
The values for NEISP, used in determining whether multishift
will be used.
line 8: NBMVAL, INTEGER array, dimension (NPARM)
The values for MINNB, used in determining minimum blocksize.
line 9: NBKVAL, INTEGER array, dimension (NPARM)
The values for MINBLK, also used in determining minimum
blocksize.
line 10: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 11: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 12: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 13 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed. For the nonsymmetric eigenvalue problem, the path name is
'DHG'. A line to request all the routines in this path has the form
DHG T T T T T T T T T T T T T T T T T T
where the first 3 characters specify the path name, and up to MAXTYP
nonblank characters may appear in columns 4-80. If the k-th such
character is 'T' or 't', the k-th routine will be timed. If at least
one but fewer than 18 nonblank characters are specified, the
remaining routines will not be timed. If columns 4-80 are blank, all
the routines will be timed, so the input line
DHG
is equivalent to the line above.
=======================================================================
The workspace requirements in terms of square matrices for the
different test paths are as follows:
NEP: 3 N**2 + N*(3*NB+2)
SEP: 2 N**2 + N*(2*N) + N
SVD: 4 N**2 + MAX( 6*N, MAXIN*MAXPRM*MAXT )
GEP: 6 N**2 + 3*N
MAXN is currently set to 400,
LG2MXN = ceiling of log-base-2 of MAXN = 9, and LDAMAX = 420.
The real work space needed is LWORK = MAX( MAXN*(4*MAXN+2),
2*LDAMAX+1+3*MAXN+2*MAXN*LG2MXN+3*MAXN**2 ), and the integer
workspace needed is LIWRK2 = 6 + 6*MAXN + 5*MAXN*LG2MXN.
For SVD, we assume NRHS may be as big
as N. The parameter NEED is set to 4 to allow for 4 NxN matrices
for SVD. */
s1 = dsecnd_();
fatal = FALSE_;
nep = FALSE_;
sep = FALSE_;
svd = FALSE_;
gep = FALSE_;
/* Read the 3-character test path */
i__1 = s_rsfe(&io___9);
if (i__1 != 0) {
goto L160;
}
i__1 = do_fio(&c__1, path, (ftnlen)3);
if (i__1 != 0) {
goto L160;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L160;
}
nep = lsamen_(&c__3, path, "NEP") || lsamen_(&c__3,
path, "DHS");
sep = lsamen_(&c__3, path, "SEP") || lsamen_(&c__3,
path, "DST");
svd = lsamen_(&c__3, path, "SVD") || lsamen_(&c__3,
path, "DBD");
gep = lsamen_(&c__3, path, "GEP") || lsamen_(&c__3,
path, "DHG");
/* Report values of parameters as they are read. */
if (nep) {
s_wsfe(&io___11);
e_wsfe();
} else if (sep) {
s_wsfe(&io___12);
e_wsfe();
} else if (svd) {
s_wsfe(&io___13);
e_wsfe();
} else if (gep) {
s_wsfe(&io___14);
e_wsfe();
} else {
s_wsfe(&io___15);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
s_stop("", (ftnlen)0);
}
s_wsfe(&io___16);
e_wsfe();
s_wsfe(&io___17);
e_wsfe();
/* Read the number of values of M and N. */
s_rsle(&io___18);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn < 1) {
s_wsfe(&io___20);
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___21);
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_;
}
/* Read the values of M */
s_rsle(&io___22);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
if (svd) {
s_copy(vname, " M", (ftnlen)6, (ftnlen)3);
} else {
s_copy(vname, " N", (ftnlen)6, (ftnlen)3);
}
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
if (mval[i__ - 1] < 0) {
s_wsfe(&io___26);
do_fio(&c__1, vname, (ftnlen)6);
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] > 400) {
s_wsfe(&io___27);
do_fio(&c__1, vname, (ftnlen)6);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__400, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
/* Read the values of N */
if (svd) {
s_wsfe(&io___28);
do_fio(&c__1, "M ", (ftnlen)4);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_rsle(&io___29);
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___31);
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] > 400) {
s_wsfe(&io___32);
do_fio(&c__1, "N ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&c__400, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L20: */
}
} else {
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
nval[i__ - 1] = mval[i__ - 1];
/* L30: */
}
}
s_wsfe(&io___33);
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 number of parameter values. */
s_rsle(&io___34);
do_lio(&c__3, &c__1, (char *)&nparms, (ftnlen)sizeof(integer));
e_rsle();
if (nparms < 1) {
s_wsfe(&io___36);
do_fio(&c__1, "NPARMS", (ftnlen)6);
do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nparms = 0;
fatal = TRUE_;
} else if (nparms > 12) {
s_wsfe(&io___37);
do_fio(&c__1, "NPARMS", (ftnlen)6);
do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nparms = 0;
fatal = TRUE_;
}
/* Read the values of NB */
s_rsle(&io___38);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbval[i__ - 1] < 0) {
s_wsfe(&io___40);
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: */
}
s_wsfe(&io___41);
do_fio(&c__1, "NB ", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
if (nep || gep) {
/* Read the values of NSHIFT */
s_rsle(&io___42);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nsval[i__ - 1] < 0) {
s_wsfe(&io___44);
do_fio(&c__1, "NS ", (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_;
}
/* L50: */
}
s_wsfe(&io___45);
do_fio(&c__1, "NS ", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Read the values of MAXB */
s_rsle(&io___46);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (mxbval[i__ - 1] < 0) {
s_wsfe(&io___48);
do_fio(&c__1, "MAXB", (ftnlen)4);
do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L60: */
}
s_wsfe(&io___49);
do_fio(&c__1, "MAXB", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
} else {
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
nsval[i__ - 1] = 1;
mxbval[i__ - 1] = 1;
/* L70: */
}
}
if (gep) {
/* Read the values of NBMIN */
s_rsle(&io___50);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbmval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbmval[i__ - 1] < 0) {
s_wsfe(&io___52);
do_fio(&c__1, "NBMIN", (ftnlen)5);
do_fio(&c__1, (char *)&nbmval[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L80: */
}
s_wsfe(&io___53);
do_fio(&c__1, "NBMIN", (ftnlen)5);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbmval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Read the values of MINBLK */
s_rsle(&io___54);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbkval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbkval[i__ - 1] < 0) {
s_wsfe(&io___56);
do_fio(&c__1, "MINBLK", (ftnlen)6);
do_fio(&c__1, (char *)&nbkval[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L90: */
}
s_wsfe(&io___57);
do_fio(&c__1, "MINBLK", (ftnlen)6);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbkval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
} else {
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
nbmval[i__ - 1] = 401;
nbkval[i__ - 1] = 401;
/* L100: */
}
}
/* Read the values of LDA */
s_rsle(&io___58);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer)
);
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ldaval[i__ - 1] < 0) {
s_wsfe(&io___60);
do_fio(&c__1, "LDA ", (ftnlen)4);
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (ldaval[i__ - 1] > 420) {
s_wsfe(&io___61);
do_fio(&c__1, "LDA ", (ftnlen)4);
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__420, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L110: */
}
s_wsfe(&io___62);
do_fio(&c__1, "LDA ", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Read the minimum time a subroutine will be timed. */
s_rsle(&io___63);
do_lio(&c__5, &c__1, (char *)&timmin, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___65);
do_fio(&c__1, (char *)&timmin, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the number of matrix types to use in timing. */
s_rsle(&io___66);
do_lio(&c__3, &c__1, (char *)&ntypes, (ftnlen)sizeof(integer));
e_rsle();
if (ntypes < 0) {
s_wsfe(&io___68);
do_fio(&c__1, "NTYPES", (ftnlen)6);
do_fio(&c__1, (char *)&ntypes, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
ntypes = 0;
}
/* Read the matrix types. */
if (nep) {
maxtyp = mxtype[0];
} else if (sep) {
maxtyp = mxtype[1];
} else if (svd) {
maxtyp = mxtype[2];
} else {
maxtyp = mxtype[3];
}
if (ntypes < maxtyp) {
s_rsle(&io___70);
i__1 = ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&iwork[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = maxtyp;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__ - 1] = FALSE_;
/* L120: */
}
i__1 = ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
if (iwork[i__ - 1] < 0) {
s_wsfe(&io___73);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&iwork[i__ - 1], (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (iwork[i__ - 1] > maxtyp) {
s_wsfe(&io___74);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&iwork[i__ - 1], (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&maxtyp, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else {
dotype[iwork[i__ - 1] - 1] = TRUE_;
}
/* L130: */
}
} else {
ntypes = maxtyp;
for (i__ = 1; i__ <= 10; ++i__) {
dotype[i__ - 1] = TRUE_;
/* L140: */
}
}
if (fatal) {
s_wsfe(&io___75);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Read the input lines indicating the test path and the routines
to be timed. The first three characters indicate the test path. */
L150:
i__1 = s_rsfe(&io___76);
if (i__1 != 0) {
goto L160;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L160;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L160;
}
s_copy(c3, line, (ftnlen)3, (ftnlen)3);
/* -------------------------------------
NEP: Nonsymmetric Eigenvalue Problem
------------------------------------- */
if (lsamen_(&c__3, c3, "DHS") || lsamen_(&c__3, c3,
"NEP")) {
dtim21_(line, &nn, nval, &maxtyp, dotype, &nparms, nbval, nsval,
mxbval, ldaval, &timmin, &c__6, iseed, &a_ref(1, 1), &a_ref(1,
2), &a_ref(1, 3), &d___ref(1, 1), work, &c_b226, logwrk,
iwork2, result, &c__10, &c__10, &c__12, opcnts, &c__10, &
c__10, &c__12, &info, (ftnlen)80);
if (info != 0) {
s_wsfe(&io___87);
do_fio(&c__1, "DTIM21", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
/* ----------------------------------
SEP: Symmetric Eigenvalue Problem
---------------------------------- */
} else if (lsamen_(&c__3, c3, "DST") || lsamen_(&
c__3, c3, "SEP")) {
dtim22_(line, &nn, nval, &maxtyp, dotype, &nparms, nbval, ldaval, &
timmin, &c__6, iseed, &a_ref(1, 1), &d___ref(1, 1), &d___ref(
1, 2), &d___ref(1, 3), &a_ref(1, 2), &a_ref(1, 3), work, &
c_b226, logwrk, iwork2, result, &c__10, &c__10, &c__12,
opcnts, &c__10, &c__10, &c__12, &info, (ftnlen)80);
if (info != 0) {
s_wsfe(&io___88);
do_fio(&c__1, "DTIM22", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
/* ----------------------------------
SVD: Singular Value Decomposition
---------------------------------- */
} else if (lsamen_(&c__3, c3, "DBD") || lsamen_(&
c__3, c3, "SVD")) {
dtim26_(line, &nn, nval, mval, &maxtyp, dotype, &nparms, nbval,
ldaval, &timmin, &c__6, iseed, &a_ref(1, 1), &a_ref(1, 2), &
a_ref(1, 3), &a_ref(1, 4), &d___ref(1, 1), &d___ref(1, 2), &
d___ref(1, 3), &d___ref(1, 4), work, &c_b226, iwork2, logwrk,
result, &c__10, &c__10, &c__12, opcnts, &c__10, &c__10, &
c__12, &info, (ftnlen)80);
if (info != 0) {
s_wsfe(&io___89);
do_fio(&c__1, "DTIM26", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
/* -------------------------------------------------
GEP: Generalized Nonsymmetric Eigenvalue Problem
------------------------------------------------- */
} else if (lsamen_(&c__3, c3, "DHG") || lsamen_(&
c__3, c3, "GEP")) {
dtim51_(line, &nn, nval, &maxtyp, dotype, &nparms, nbval, nsval,
mxbval, nbmval, nbkval, ldaval, &timmin, &c__6, iseed, &a_ref(
1, 1), &a_ref(1, 2), &a_ref(1, 3), &a_ref(1, 4), &a_ref(1, 5),
&a_ref(1, 6), &d___ref(1, 1), work, &c_b226, logwrk, result,
&c__10, &c__10, &c__12, opcnts, &c__10, &c__10, &c__12, &info,
(ftnlen)80);
if (info != 0) {
s_wsfe(&io___90);
do_fio(&c__1, "DTIM51", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
} else {
s_wsle(&io___91);
e_wsle();
s_wsle(&io___92);
e_wsle();
s_wsfe(&io___93);
do_fio(&c__1, c3, (ftnlen)3);
e_wsfe();
}
goto L150;
L160:
s_wsfe(&io___94);
e_wsfe();
s2 = dsecnd_();
s_wsfe(&io___96);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* End of DTIMEE */
return 0;
} /* MAIN__ */
